Theory Category
chapter "Category"
theory Category
imports Main "HOL-Library.FuncSet"
begin
text ‹
This theory develops an ``object-free'' definition of category loosely following
\cite{AHS}, Sec. 3.52-3.53.
We define the notion ``category'' in terms of axioms that concern a single
partial binary operation on a type, some of whose elements are to be regarded
as the ``arrows'' of the category.
The nonstandard definition of category has some advantages and disadvantages.
An advantage is that only one piece of data (the composition operation) is required
to specify a category, so the use of records is not required to bundle up several
separate objects. A related advantage is the fact that functors and natural
transformations can be defined simply to be functions that satisfy certain axioms,
rather than more complex composite objects.
One disadvantage is that the notions of ``object'' and ``identity arrow'' are
conflated, though this is easy to get used to. Perhaps a more significant disadvantage
is that each arrow of a category must carry along the information about its domain
and codomain. This implies, for example, that the arrows of a category of sets and
functions cannot be directly identified with functions, but rather only with functions that
have been equipped with their domain and codomain sets.
To represent the partiality of the composition operation of a category, we assume that the
composition for a category has a unique zero element, which we call ‹null›,
and we consider arrows to be ``composable'' if and only if their composite is non-null.
Functors and natural transformations are required to map arrows to arrows and be
``extensional'' in the sense that they map non-arrows to null. This is so that
equality of functors and natural transformations coincides with their extensional equality
as functions in HOL.
The fact that we co-opt an element of the arrow type to serve as ‹null› means that
it is not possible to define a category whose arrows exhaust the elements of a given type.
This presents a disadvantage in some situations. For example, we cannot construct a
discrete category whose arrows are directly identified with the set of \emph{all}
elements of a given type @{typ 'a}; instead, we must pass to a larger type
(such as @{typ "'a option"}) so that there is an element available for use as ‹null›.
The presence of ‹null›, however, is crucial to our being able to define a
system of introduction and elimination rules that can be applied automatically to establish
that a given expression denotes an arrow. Without ‹null›, we would be able to
define an introduction rule to infer, say, that the composition of composable arrows
is composable, but not an elimination rule to infer that arrows are composable from
the fact that their composite is an arrow. Having the ability to do both is critical
to the usability of the theory.
›
section "Partial Magmas"
text ‹
A \emph{partial magma} is a partial binary operation ‹C› defined on the set
of elements at a type @{typ 'a}. As discussed above,
we assume the existence of a unique element ‹null› of type @{typ 'a}
that is a zero for ‹C›, and we use ‹null› to represent ``undefined''.
We think of the operation ‹C› as an operation of ``composition'', and
we regard elements ‹f› and ‹g› of type @{typ 'a} as \emph{composable}
if ‹C g f ≠ null›.
›
type_synonym 'a comp = "'a ⇒ 'a ⇒ 'a"
locale partial_magma =
fixes C :: "'a comp" (infixr "⋅" 55)
assumes ex_un_null: "∃!n. ∀f. n ⋅ f = n ∧ f ⋅ n = n"
begin
definition null :: 'a
where "null = (THE n. ∀f. n ⋅ f = n ∧ f ⋅ n = n)"
lemma null_eqI:
assumes "⋀f. n ⋅ f = n ∧ f ⋅ n = n"
shows "n = null"
using assms null_def ex_un_null the1_equality [of "λn. ∀f. n ⋅ f = n ∧ f ⋅ n = n"]
by auto
lemma comp_null [simp]:
shows "null ⋅ f = null" and "f ⋅ null = null"
using null_def ex_un_null theI' [of "λn. ∀f. n ⋅ f = n ∧ f ⋅ n = n"]
by auto
text ‹
An \emph{identity} is a self-composable element ‹a› such that composition of
any other element ‹f› with ‹a› on either the left or the right results in
‹f› whenever the composition is defined.
›
definition ide
where "ide a ≡ a ⋅ a ≠ null ∧
(∀f. (f ⋅ a ≠ null ⟶ f ⋅ a = f) ∧ (a ⋅ f ≠ null ⟶ a ⋅ f = f))"
text ‹
A \emph{domain} of an element ‹f› is an identity ‹a› for which composition of
‹f› with ‹a› on the right is defined.
The notion \emph{codomain} is defined similarly, using composition on the left.
Note that, although these definitions are completely dual, the choice of terminology
implies that we will think of composition as being written in traditional order,
as opposed to diagram order. It is pretty much essential to do it this way, to maintain
compatibility with the notation for function application once we start working with
functors and natural transformations.
›
definition domains
where "domains f ≡ {a. ide a ∧ f ⋅ a ≠ null}"
definition codomains
where "codomains f ≡ {b. ide b ∧ b ⋅ f ≠ null}"
lemma domains_null:
shows "domains null = {}"
by (simp add: domains_def)
lemma codomains_null:
shows "codomains null = {}"
by (simp add: codomains_def)
lemma self_domain_iff_ide:
shows "a ∈ domains a ⟷ ide a"
using ide_def domains_def by auto
lemma self_codomain_iff_ide:
shows "a ∈ codomains a ⟷ ide a"
using ide_def codomains_def by auto
text ‹
An element ‹f› is an \emph{arrow} if either it has a domain or it has a codomain.
In an arbitrary partial magma it is possible for ‹f› to have one but not the other,
but the ‹category› locale will include assumptions to rule this out.
›
definition arr
where "arr f ≡ domains f ≠ {} ∨ codomains f ≠ {}"
lemma not_arr_null [simp]:
shows "¬ arr null"
by (simp add: arr_def domains_null codomains_null)
text ‹
Using the notions of domain and codomain, we can define \emph{homs}.
The predicate @{term "in_hom f a b"} expresses ``@{term f} is an arrow from @{term a}
to @{term b},'' and the term @{term "hom a b"} denotes the set of all such arrows.
It is convenient to have both of these, though passing back and forth sometimes involves
extra work. We choose @{term "in_hom"} as the more fundamental notion.
›
definition in_hom ("«_ : _ → _»")
where "«f : a → b» ≡ a ∈ domains f ∧ b ∈ codomains f"
abbreviation hom
where "hom a b ≡ {f. «f : a → b»}"
lemma arrI:
assumes "«f : a → b»"
shows "arr f"
using assms arr_def in_hom_def by auto
lemma ide_in_hom [intro]:
shows "ide a ⟷ «a : a → a»"
using self_domain_iff_ide self_codomain_iff_ide in_hom_def ide_def by fastforce
text ‹
Arrows @{term "f"} @{term "g"} for which the composite @{term "g ⋅ f"} is defined
are \emph{sequential}.
›
abbreviation seq
where "seq g f ≡ arr (g ⋅ f)"
lemma comp_arr_ide:
assumes "ide a" and "seq f a"
shows "f ⋅ a = f"
using assms ide_in_hom ide_def not_arr_null by metis
lemma comp_ide_arr:
assumes "ide b" and "seq b f"
shows "b ⋅ f = f"
using assms ide_in_hom ide_def not_arr_null by metis
text ‹
The \emph{domain} of an arrow @{term f} is an element chosen arbitrarily from the
set of domains of @{term f} and the \emph{codomain} of @{term f} is an element chosen
arbitrarily from the set of codomains.
›
definition dom
where "dom f = (if domains f ≠ {} then (SOME a. a ∈ domains f) else null)"
definition cod
where "cod f = (if codomains f ≠ {} then (SOME b. b ∈ codomains f) else null)"
lemma dom_null [simp]:
shows "dom null = null"
by (simp add: dom_def domains_null)
lemma cod_null [simp]:
shows "cod null = null"
by (simp add: cod_def codomains_null)
lemma dom_in_domains:
assumes "domains f ≠ {}"
shows "dom f ∈ domains f"
using assms dom_def someI [of "λa. a ∈ domains f"] by auto
lemma cod_in_codomains:
assumes "codomains f ≠ {}"
shows "cod f ∈ codomains f"
using assms cod_def someI [of "λb. b ∈ codomains f"] by auto
end
section "Categories"
text‹
A \emph{category} is defined to be a partial magma whose composition satisfies an
extensionality condition, an associativity condition, and the requirement that every
arrow have both a domain and a codomain.
The associativity condition involves four ``matching conditions''
(‹match_1›, ‹match_2›, ‹match_3›, and ‹match_4›)
which constrain the domain of definition of the composition, and a fifth condition
(‹comp_assoc'›) which states that the results of the two ways of composing
three elements are equal. In the presence of the ‹comp_assoc'› axiom
‹match_4› can be derived from ‹match_3› and vice versa.
›
locale category = partial_magma +
assumes ext: "g ⋅ f ≠ null ⟹ seq g f"
and has_domain_iff_has_codomain: "domains f ≠ {} ⟷ codomains f ≠ {}"
and match_1: "⟦ seq h g; seq (h ⋅ g) f ⟧ ⟹ seq g f"
and match_2: "⟦ seq h (g ⋅ f); seq g f ⟧ ⟹ seq h g"
and match_3: "⟦ seq g f; seq h g ⟧ ⟹ seq (h ⋅ g) f"
and comp_assoc': "⟦ seq g f; seq h g ⟧ ⟹ (h ⋅ g) ⋅ f = h ⋅ g ⋅ f"
begin
text‹
Associativity of composition holds unconditionally. This was not the case in
previous, weaker versions of this theory, and I did not notice this for some
time after updating to the current axioms. It is obviously an advantage that
no additional hypotheses have to be verified in order to apply associativity,
but a disadvantage is that this fact is now ``too readily applicable,''
so that if it is made a default simplification it tends to get in the way of
applying other simplifications that we would also like to be able to apply automatically.
So, it now seems best not to make this fact a default simplification, but rather
to invoke it explicitly where it is required.
›
lemma comp_assoc:
shows "(h ⋅ g) ⋅ f = h ⋅ g ⋅ f"
by (metis comp_assoc' ex_un_null ext match_1 match_2)
lemma match_4:
assumes "seq g f" and "seq h g"
shows "seq h (g ⋅ f)"
using assms match_3 comp_assoc by auto
lemma domains_comp:
assumes "seq g f"
shows "domains (g ⋅ f) = domains f"
proof -
have "domains (g ⋅ f) = {a. ide a ∧ seq (g ⋅ f) a}"
using domains_def ext by auto
also have "... = {a. ide a ∧ seq f a}"
using assms ide_def match_1 match_3 by meson
also have "... = domains f"
using domains_def ext by auto
finally show ?thesis by blast
qed
lemma codomains_comp:
assumes "seq g f"
shows "codomains (g ⋅ f) = codomains g"
proof -
have "codomains (g ⋅ f) = {b. ide b ∧ seq b (g ⋅ f)}"
using codomains_def ext by auto
also have "... = {b. ide b ∧ seq b g}"
using assms ide_def match_2 match_4 by meson
also have "... = codomains g"
using codomains_def ext by auto
finally show ?thesis by blast
qed
lemma has_domain_iff_arr:
shows "domains f ≠ {} ⟷ arr f"
by (simp add: arr_def has_domain_iff_has_codomain)
lemma has_codomain_iff_arr:
shows "codomains f ≠ {} ⟷ arr f"
using has_domain_iff_arr has_domain_iff_has_codomain by auto
text‹
A consequence of the category axioms is that domains and codomains, if they exist,
are unique.
›
lemma domain_unique:
assumes "a ∈ domains f" and "a' ∈ domains f"
shows "a = a'"
proof -
have "ide a ∧ seq f a ∧ ide a' ∧ seq f a'"
using assms domains_def ext by force
thus ?thesis
using match_1 ide_def not_arr_null by metis
qed
lemma codomain_unique:
assumes "b ∈ codomains f" and "b' ∈ codomains f"
shows "b = b'"
proof -
have "ide b ∧ seq b f ∧ ide b' ∧ seq b' f"
using assms codomains_def ext by force
thus ?thesis
using match_2 ide_def not_arr_null by metis
qed
lemma domains_simp:
assumes "arr f"
shows "domains f = {dom f}"
using assms dom_in_domains has_domain_iff_arr domain_unique by auto
lemma codomains_simp:
assumes "arr f"
shows "codomains f = {cod f}"
using assms cod_in_codomains has_codomain_iff_arr codomain_unique by auto
lemma domains_char:
shows "domains f = (if arr f then {dom f} else {})"
using dom_in_domains has_domain_iff_arr domain_unique by auto
lemma codomains_char:
shows "codomains f = (if arr f then {cod f} else {})"
using cod_in_codomains has_codomain_iff_arr codomain_unique by auto
text‹
A consequence of the following lemma is that the notion @{term "arr"} is redundant,
given @{term "in_hom"}, @{term "dom"}, and @{term "cod"}. However, I have retained it
because I have not been able to find a set of usefully powerful simplification rules
expressed only in terms of @{term "in_hom"} that does not result in looping in many
situations.
›
lemma arr_iff_in_hom:
shows "arr f ⟷ «f : dom f → cod f»"
using cod_in_codomains dom_in_domains has_domain_iff_arr has_codomain_iff_arr in_hom_def
by auto
lemma in_homI [intro]:
assumes "arr f" and "dom f = a" and "cod f = b"
shows "«f : a → b»"
using assms cod_in_codomains dom_in_domains has_domain_iff_arr has_codomain_iff_arr
in_hom_def
by auto
lemma in_homE [elim]:
assumes "«f : a → b»"
and "arr f ⟹ dom f = a ⟹ cod f = b ⟹ T"
shows "T"
using assms in_hom_def domains_char codomains_char has_domain_iff_arr
by (metis empty_iff singleton_iff)
text‹
To obtain the ``only if'' direction in the next two results and in similar results later
for composition and the application of functors and natural transformations,
is the reason for assuming the existence of @{term null} as a special element of the
arrow type, as opposed to, say, using option types to represent partiality.
The presence of @{term null} allows us not only to make the ``upward'' inference that
the domain of an arrow is again an arrow, but also to make the ``downward'' inference
that if @{term "dom f"} is an arrow then so is @{term f}. Similarly, we will be able
to infer not only that if @{term f} and @{term g} are composable arrows then
@{term "C g f"} is an arrow, but also that if @{term "C g f"} is an arrow then
‹f› and ‹g› are composable arrows. These inferences allow most necessary
facts about what terms denote arrows to be deduced automatically from minimal
assumptions. Typically all that is required is to assume or establish that certain
terms denote arrows in particular homs at the point where those terms are first
introduced, and then similar facts about related terms can be derived automatically.
Without this feature, nearly every proof would involve many tedious additional steps
to establish that each of the terms appearing in the proof (including all its subterms)
in fact denote arrows.
›
lemma arr_dom_iff_arr:
shows "arr (dom f) ⟷ arr f"
using dom_def dom_in_domains has_domain_iff_arr self_domain_iff_ide domains_def
by fastforce
lemma arr_cod_iff_arr:
shows "arr (cod f) ⟷ arr f"
using cod_def cod_in_codomains has_codomain_iff_arr self_codomain_iff_ide codomains_def
by fastforce
lemma arr_dom [simp]:
assumes "arr f"
shows "arr (dom f)"
using assms arr_dom_iff_arr by simp
lemma arr_cod [simp]:
assumes "arr f"
shows "arr (cod f)"
using assms arr_cod_iff_arr by simp
lemma seqI [simp]:
assumes "arr f" and "arr g" and "dom g = cod f"
shows "seq g f"
proof -
have "ide (cod f) ∧ seq (cod f) f"
using assms(1) has_codomain_iff_arr codomains_def cod_in_codomains ext by blast
moreover have "ide (cod f) ∧ seq g (cod f)"
using assms(2-3) domains_def domains_simp ext by fastforce
ultimately show ?thesis
using match_4 ide_def ext by metis
qed
text ‹
This version of ‹seqI› is useful as an introduction rule, but not as useful
as a simplification, because it requires finding the intermediary term ‹b›.
Sometimes \emph{auto} is able to do this, but other times it is more expedient
just to invoke this rule and fill in the missing terms manually, especially
when dealing with a chain of compositions.
›
lemma seqI' [intro]:
assumes "«f : a → b»" and "«g : b → c»"
shows "seq g f"
using assms by fastforce
lemma compatible_iff_seq:
shows "domains g ∩ codomains f ≠ {} ⟷ seq g f"
proof
show "domains g ∩ codomains f ≠ {} ⟹ seq g f"
using cod_in_codomains dom_in_domains empty_iff has_domain_iff_arr has_codomain_iff_arr
domain_unique codomain_unique
by (metis Int_emptyI seqI)
show "seq g f ⟹ domains g ∩ codomains f ≠ {}"
proof -
assume gf: "seq g f"
have 1: "cod f ∈ codomains f"
using gf has_domain_iff_arr domains_comp cod_in_codomains codomains_simp by blast
have "ide (cod f) ∧ seq (cod f) f"
using 1 codomains_def ext by auto
hence "seq g (cod f)"
using gf has_domain_iff_arr match_2 domains_null ide_def by metis
thus ?thesis
using domains_def 1 codomains_def by auto
qed
qed
text‹
The following is another example of a crucial ``downward'' rule that would not be possible
without a reserved @{term null} value.
›
lemma seqE [elim]:
assumes "seq g f"
and "arr f ⟹ arr g ⟹ dom g = cod f ⟹ T"
shows "T"
using assms cod_in_codomains compatible_iff_seq has_domain_iff_arr has_codomain_iff_arr
domains_comp codomains_comp domains_char codomain_unique
by (metis Int_emptyI singletonD)
lemma comp_in_homI [intro]:
assumes "«f : a → b»" and "«g : b → c»"
shows "«g ⋅ f : a → c»"
proof
show 1: "seq g f" using assms compatible_iff_seq by blast
show "dom (g ⋅ f) = a"
using assms 1 domains_comp domains_simp by blast
show "cod (g ⋅ f) = c"
using assms 1 codomains_comp codomains_simp by blast
qed
lemma comp_in_homI' [simp]:
assumes "arr f" and "arr g" and "dom f = a" and "cod g = c" and "dom g = cod f"
shows "«g ⋅ f : a → c»"
using assms by auto
lemma comp_in_homE [elim]:
assumes "«g ⋅ f : a → c»"
obtains b where "«f : a → b»" and "«g : b → c»"
using assms in_hom_def domains_comp codomains_comp
by (metis arrI in_homI seqE)
text ‹
The next two rules are useful as simplifications, but they slow down the
simplifier too much to use them by default. So it is necessary to guess when
they are needed and cite them explicitly. This is usually not too difficult.
›
lemma comp_arr_dom:
assumes "arr f" and "dom f = a"
shows "f ⋅ a = f"
using assms dom_in_domains has_domain_iff_arr domains_def ide_def by auto
lemma comp_cod_arr:
assumes "arr f" and "cod f = b"
shows "b ⋅ f = f"
using assms cod_in_codomains has_codomain_iff_arr ide_def codomains_def by auto
lemma ide_char:
shows "ide a ⟷ arr a ∧ dom a = a ∧ cod a = a"
using ide_in_hom by auto
text ‹
In some contexts, this rule causes the simplifier to loop, but it is too useful
not to have as a default simplification. In cases where it is a problem, usually
a method like \emph{blast} or \emph{force} will succeed if this rule is cited
explicitly.
›
lemma ideD [simp]:
assumes "ide a"
shows "arr a" and "dom a = a" and "cod a = a"
using assms ide_char by auto
lemma ide_dom [simp]:
assumes "arr f"
shows "ide (dom f)"
using assms dom_in_domains has_domain_iff_arr domains_def by auto
lemma ide_cod [simp]:
assumes "arr f"
shows "ide (cod f)"
using assms cod_in_codomains has_codomain_iff_arr codomains_def by auto
lemma dom_eqI:
assumes "ide a" and "seq f a"
shows "dom f = a"
using assms cod_in_codomains codomain_unique ide_char
by (metis seqE)
lemma cod_eqI:
assumes "ide b" and "seq b f"
shows "cod f = b"
using assms dom_in_domains domain_unique ide_char
by (metis seqE)
lemma dom_eqI':
assumes "a ∈ domains f"
shows "a = dom f"
using assms dom_in_domains domain_unique by blast
lemma cod_eqI':
assumes "a ∈ codomains f"
shows "a = cod f"
using assms cod_in_codomains codomain_unique by blast
lemma ide_char':
shows "ide a ⟷ arr a ∧ (dom a = a ∨ cod a = a)"
using ide_dom ide_cod ide_char by metis
lemma dom_dom:
assumes "arr f"
shows "dom (dom f) = dom f"
using assms by simp
lemma cod_cod:
assumes "arr f"
shows "cod (cod f) = cod f"
using assms by simp
lemma dom_cod:
assumes "arr f"
shows "dom (cod f) = cod f"
using assms by simp
lemma cod_dom:
assumes "arr f"
shows "cod (dom f) = dom f"
using assms by simp
lemma dom_comp [simp]:
assumes "seq g f"
shows "dom (g ⋅ f) = dom f"
using assms by (simp add: dom_def domains_comp)
lemma cod_comp [simp]:
assumes "seq g f"
shows "cod (g ⋅ f) = cod g"
using assms by (simp add: cod_def codomains_comp)
lemma comp_ide_self [simp]:
assumes "ide a"
shows "a ⋅ a = a"
using assms comp_arr_ide arrI by auto
lemma ide_compE [elim]:
assumes "ide (g ⋅ f)"
and "seq g f ⟹ seq f g ⟹ g ⋅ f = dom f ⟹ g ⋅ f = cod g ⟹ T"
shows "T"
using assms dom_comp cod_comp ide_char ide_in_hom
by (metis seqE seqI)
text ‹
The next two results are sometimes useful for performing manipulations at the
head of a chain of composed arrows. I have adopted the convention that such
chains are canonically represented in right-associated form. This makes it
easy to perform manipulations at the ``tail'' of a chain, but more difficult
to perform them at the ``head''. These results take care of the rote manipulations
using associativity that are needed to either permute or combine arrows at the
head of a chain.
›
lemma comp_permute:
assumes "f ⋅ g = k ⋅ l" and "seq f g" and "seq g h"
shows "f ⋅ g ⋅ h = k ⋅ l ⋅ h"
using assms by (metis comp_assoc)
lemma comp_reduce:
assumes "f ⋅ g = k" and "seq f g" and "seq g h"
shows "f ⋅ g ⋅ h = k ⋅ h"
using assms comp_assoc by auto
text‹
Here we define some common configurations of arrows.
These are defined as abbreviations, because we want all ``diagrammatic'' assumptions
in a theorem to reduce readily to a conjunction of assertions of the basic forms
@{term "arr f"}, @{term "dom f = X"}, @{term "cod f = Y"}, and @{term "in_hom f a b"}.
›
abbreviation endo
where "endo f ≡ seq f f"
abbreviation antipar
where "antipar f g ≡ seq g f ∧ seq f g"
abbreviation span
where "span f g ≡ arr f ∧ arr g ∧ dom f = dom g"
abbreviation cospan
where "cospan f g ≡ arr f ∧ arr g ∧ cod f = cod g"
abbreviation par
where "par f g ≡ arr f ∧ arr g ∧ dom f = dom g ∧ cod f = cod g"
end
end
Theory ConcreteCategory
chapter "Concrete Categories"
text ‹
In this section we define a locale ‹concrete_category›, which provides a uniform
(and more traditional) way to construct a category from specified sets of objects and arrows,
with specified identity objects and composition of arrows.
We prove that the identities and arrows of the constructed category are appropriately
in bijective correspondence with the given sets and that domains, codomains, and composition
in the constructed category are as expected according to this correspondence.
In the later theory ‹Functor›, once we have defined functors and isomorphisms of categories,
we will show a stronger property of this construction: if ‹C› is any category,
then ‹C› is isomorphic to the concrete category formed from it in the obvious way by taking
the identities of ‹C› as objects, the set of arrows of ‹C› as arrows, the identities of
‹C› as identity objects, and defining composition of arrows using the composition of ‹C›.
Thus no information about ‹C› is lost by extracting its objects, arrows, identities, and
composition and rebuilding it as a concrete category.
We note, however, that we do not assume that the composition function given as parameter
to the concrete category construction is ``extensional'', so in general it will contain
incidental information about composition of non-composable arrows, and this information
is not preserved by the concrete category construction.
›
theory ConcreteCategory
imports Category
begin
locale concrete_category =
fixes Obj :: "'o set"
and Hom :: "'o ⇒ 'o ⇒ 'a set"
and Id :: "'o ⇒ 'a"
and Comp :: "'o ⇒ 'o ⇒ 'o ⇒ 'a ⇒ 'a ⇒'a"
assumes Id_in_Hom: "A ∈ Obj ⟹ Id A ∈ Hom A A"
and Comp_in_Hom: "⟦ A ∈ Obj; B ∈ Obj; C ∈ Obj; f ∈ Hom A B; g ∈ Hom B C ⟧
⟹ Comp C B A g f ∈ Hom A C"
and Comp_Hom_Id: "⟦ A ∈ Obj; f ∈ Hom A B ⟧ ⟹ Comp B A A f (Id A) = f"
and Comp_Id_Hom: "⟦ B ∈ Obj; f ∈ Hom A B ⟧ ⟹ Comp B B A (Id B) f = f"
and Comp_assoc: "⟦ A ∈ Obj; B ∈ Obj; C ∈ Obj; D ∈ Obj;
f ∈ Hom A B; g ∈ Hom B C; h ∈ Hom C D ⟧ ⟹
Comp D C A h (Comp C B A g f) = Comp D B A (Comp D C B h g) f"
begin
datatype ('oo, 'aa) arr =
Null
| MkArr 'oo 'oo 'aa
abbreviation MkIde :: "'o ⇒ ('o, 'a) arr"
where "MkIde A ≡ MkArr A A (Id A)"
fun Dom :: "('o, 'a) arr ⇒ 'o"
where "Dom (MkArr A _ _) = A"
| "Dom _ = undefined"
fun Cod
where "Cod (MkArr _ B _) = B"
| "Cod _ = undefined"
fun Map
where "Map (MkArr _ _ F) = F"
| "Map _ = undefined"
abbreviation Arr
where "Arr f ≡ f ≠ Null ∧ Dom f ∈ Obj ∧ Cod f ∈ Obj ∧ Map f ∈ Hom (Dom f) (Cod f)"
abbreviation Ide
where "Ide a ≡ a ≠ Null ∧ Dom a ∈ Obj ∧ Cod a = Dom a ∧ Map a = Id (Dom a)"
definition COMP :: "('o, 'a) arr comp"
where "COMP g f ≡ if Arr f ∧ Arr g ∧ Dom g = Cod f then
MkArr (Dom f) (Cod g) (Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f))
else
Null"
interpretation partial_magma COMP
using COMP_def by (unfold_locales, metis)
lemma null_char:
shows "null = Null"
proof -
let ?P = "λn. ∀f. COMP n f = n ∧ COMP f n = n"
have "Null = null"
using COMP_def null_def the1_equality [of ?P]
by (metis (no_types, lifting))
thus ?thesis by simp
qed
lemma ide_char:
shows "ide f ⟷ Ide f"
proof
assume f: "Ide f"
show "ide f"
proof -
have "COMP f f ≠ null"
using f COMP_def null_char Id_in_Hom by auto
moreover have "∀g. (COMP g f ≠ null ⟶ COMP g f = g) ∧
(COMP f g ≠ null ⟶ COMP f g = g)"
proof (intro allI conjI)
fix g
show "COMP g f ≠ null ⟶ COMP g f = g"
using f COMP_def null_char Comp_Hom_Id Id_in_Hom
by (cases g, auto)
show "COMP f g ≠ null ⟶ COMP f g = g"
using f COMP_def null_char Comp_Id_Hom Id_in_Hom
by (cases g, auto)
qed
ultimately show ?thesis
using ide_def by blast
qed
next
assume f: "ide f"
have 1: "Arr f ∧ Dom f = Cod f"
using f ide_def COMP_def null_char by metis
moreover have "Map f = Id (Dom f)"
proof -
let ?g = "MkIde (Dom f)"
have g: "Arr f ∧ Arr ?g ∧ Dom ?g = Cod f"
using 1 Id_in_Hom
by (intro conjI, simp_all)
have "COMP ?g f = MkArr (Dom f) (Dom f) (Map f)"
using g COMP_def Comp_Id_Hom by auto
moreover have "COMP ?g f = ?g"
proof -
have "COMP ?g f ≠ null"
using g 1 COMP_def null_char by simp
thus ?thesis
using f ide_def by blast
qed
ultimately show ?thesis by simp
qed
ultimately show "Ide f" by auto
qed
lemma ide_MkIde [simp]:
assumes "A ∈ Obj"
shows "ide (MkIde A)"
using assms ide_char Id_in_Hom by simp
lemma in_domains_char:
shows "a ∈ domains f ⟷ Arr f ∧ a = MkIde (Dom f)"
proof
assume a: "a ∈ domains f"
have "Ide a"
using a domains_def ide_char COMP_def null_char by auto
moreover have "Arr f ∧ Dom f = Cod a"
proof -
have "COMP f a ≠ null"
using a domains_def by simp
thus ?thesis
using a domains_def COMP_def [of f a] null_char by metis
qed
ultimately show "Arr f ∧ a = MkIde (Dom f)"
by (cases a, auto)
next
assume a: "Arr f ∧ a = MkIde (Dom f)"
show "a ∈ domains f"
using a Id_in_Hom COMP_def null_char domains_def by auto
qed
lemma in_codomains_char:
shows "b ∈ codomains f ⟷ Arr f ∧ b = MkIde (Cod f)"
proof
assume b: "b ∈ codomains f"
have "Ide b"
using b codomains_def ide_char COMP_def null_char by auto
moreover have "Arr f ∧ Dom b = Cod f"
proof -
have "COMP b f ≠ null"
using b codomains_def by simp
thus ?thesis
using b codomains_def COMP_def [of b f] null_char by metis
qed
ultimately show "Arr f ∧ b = MkIde (Cod f)"
by (cases b, auto)
next
assume b: "Arr f ∧ b = MkIde (Cod f)"
show "b ∈ codomains f"
using b Id_in_Hom COMP_def null_char codomains_def by auto
qed
lemma arr_char:
shows "arr f ⟷ Arr f"
using arr_def in_domains_char in_codomains_char by auto
lemma arrI:
assumes "f ≠ Null" and "Dom f ∈ Obj" "Cod f ∈ Obj" "Map f ∈ Hom (Dom f) (Cod f)"
shows "arr f"
using assms arr_char by blast
lemma arrE:
assumes "arr f"
and "⟦ f ≠ Null; Dom f ∈ Obj; Cod f ∈ Obj; Map f ∈ Hom (Dom f) (Cod f) ⟧ ⟹ T"
shows T
using assms arr_char by simp
lemma arr_MkArr [simp]:
assumes "A ∈ Obj" and "B ∈ Obj" and "f ∈ Hom A B"
shows "arr (MkArr A B f)"
using assms arr_char by simp
lemma MkArr_Map:
assumes "arr f"
shows "MkArr (Dom f) (Cod f) (Map f) = f"
using assms arr_char by (cases f, auto)
lemma Arr_comp:
assumes "arr f" and "arr g" and "Dom g = Cod f"
shows "Arr (COMP g f)"
unfolding COMP_def
using assms arr_char Comp_in_Hom by simp
lemma Dom_comp [simp]:
assumes "arr f" and "arr g" and "Dom g = Cod f"
shows "Dom (COMP g f) = Dom f"
unfolding COMP_def
using assms arr_char by simp
lemma Cod_comp [simp]:
assumes "arr f" and "arr g" and "Dom g = Cod f"
shows "Cod (COMP g f) = Cod g"
unfolding COMP_def
using assms arr_char by simp
lemma Map_comp [simp]:
assumes "arr f" and "arr g" and "Dom g = Cod f"
shows "Map (COMP g f) = Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f)"
unfolding COMP_def
using assms arr_char by simp
lemma seq_char:
shows "seq g f ⟷ arr f ∧ arr g ∧ Dom g = Cod f"
using arr_char not_arr_null null_char COMP_def Arr_comp by metis
interpretation category COMP
proof
show "⋀g f. COMP g f ≠ null ⟹ seq g f"
using arr_char COMP_def null_char Comp_in_Hom by auto
show 1: "⋀f. (domains f ≠ {}) = (codomains f ≠ {})"
using in_domains_char in_codomains_char by auto
show "⋀f g h. seq h g ⟹ seq (COMP h g) f ⟹ seq g f"
by (auto simp add: seq_char)
show "⋀f g h. seq h (COMP g f) ⟹ seq g f ⟹ seq h g"
using seq_char COMP_def Comp_in_Hom by (metis Cod_comp)
show "⋀f g h. seq g f ⟹ seq h g ⟹ seq (COMP h g) f"
using Comp_in_Hom
by (auto simp add: COMP_def seq_char)
show "⋀g f h. seq g f ⟹ seq h g ⟹ COMP (COMP h g) f = COMP h (COMP g f)"
using seq_char COMP_def Comp_assoc Comp_in_Hom Dom_comp Cod_comp Map_comp
by auto
qed
proposition is_category:
shows "category COMP"
..
text ‹
Functions ‹Dom›, ‹Cod›, and ‹Map› establish a correspondence between the
arrows of the constructed category and the elements of the originally given
parameters ‹Obj› and ‹Hom›.
›
lemma Dom_in_Obj:
assumes "arr f"
shows "Dom f ∈ Obj"
using assms arr_char by simp
lemma Cod_in_Obj:
assumes "arr f"
shows "Cod f ∈ Obj"
using assms arr_char by simp
lemma Map_in_Hom:
assumes "arr f"
shows "Map f ∈ Hom (Dom f) (Cod f)"
using assms arr_char by simp
lemma MkArr_in_hom:
assumes "A ∈ Obj" and "B ∈ Obj" and "f ∈ Hom A B"
shows "in_hom (MkArr A B f) (MkIde A) (MkIde B)"
using assms arr_char ide_MkIde
by (simp add: in_codomains_char in_domains_char in_hom_def)
text ‹
The next few results show that domains, codomains, and composition in the constructed
category are as expected according to the just-given correspondence.
›
lemma dom_char:
shows "dom f = (if arr f then MkIde (Dom f) else null)"
using dom_def in_domains_char dom_in_domains has_domain_iff_arr by auto
lemma cod_char:
shows "cod f = (if arr f then MkIde (Cod f) else null)"
using cod_def in_codomains_char cod_in_codomains has_codomain_iff_arr by auto
lemma comp_char:
shows "COMP g f = (if seq g f then
MkArr (Dom f) (Cod g) (Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f))
else
null)"
using COMP_def seq_char arr_char null_char by auto
lemma in_hom_char:
shows "in_hom f a b ⟷ arr f ∧ ide a ∧ ide b ∧ Dom f = Dom a ∧ Cod f = Dom b"
proof
show "in_hom f a b ⟹ arr f ∧ ide a ∧ ide b ∧ Dom f = Dom a ∧ Cod f = Dom b"
using arr_char dom_char cod_char by auto
show "arr f ∧ ide a ∧ ide b ∧ Dom f = Dom a ∧ Cod f = Dom b ⟹ in_hom f a b"
using arr_char dom_char cod_char ide_char Id_in_Hom MkArr_Map in_homI by metis
qed
lemma Dom_dom [simp]:
assumes "arr f"
shows "Dom (dom f) = Dom f"
using assms MkArr_Map dom_char by simp
lemma Cod_dom [simp]:
assumes "arr f"
shows "Cod (dom f) = Dom f"
using assms MkArr_Map dom_char by simp
lemma Dom_cod [simp]:
assumes "arr f"
shows "Dom (cod f) = Cod f"
using assms MkArr_Map cod_char by simp
lemma Cod_cod [simp]:
assumes "arr f"
shows "Cod (cod f) = Cod f"
using assms MkArr_Map cod_char by simp
lemma Map_dom [simp]:
assumes "arr f"
shows "Map (dom f) = Id (Dom f)"
using assms MkArr_Map dom_char by simp
lemma Map_cod [simp]:
assumes "arr f"
shows "Map (cod f) = Id (Cod f)"
using assms MkArr_Map cod_char by simp
lemma Map_ide:
assumes "ide a"
shows "Map a = Id (Dom a)" and "Map a = Id (Cod a)"
using assms ide_char dom_char [of a] Map_dom Map_cod ideD(1) by metis+
lemma MkIde_Dom:
assumes "arr a"
shows "MkIde (Dom a) = dom a"
using assms arr_char dom_char by (cases a, auto)
lemma MkIde_Cod:
assumes "arr a"
shows "MkIde (Cod a) = cod a"
using assms arr_char cod_char by (cases a, auto)
lemma MkIde_Dom' [simp]:
assumes "ide a"
shows "MkIde (Dom a) = a"
using assms MkIde_Dom by simp
lemma MkIde_Cod' [simp]:
assumes "ide a"
shows "MkIde (Cod a) = a"
using assms MkIde_Cod by simp
lemma dom_MkArr [simp]:
assumes "arr (MkArr A B F)"
shows "dom (MkArr A B F) = MkIde A"
using assms dom_char by simp
lemma cod_MkArr [simp]:
assumes "arr (MkArr A B F)"
shows "cod (MkArr A B F) = MkIde B"
using assms cod_char by simp
lemma comp_MkArr [simp]:
assumes "arr (MkArr A B F)" and "arr (MkArr B C G)"
shows "COMP (MkArr B C G) (MkArr A B F) = MkArr A C (Comp C B A G F)"
using assms comp_char [of "MkArr B C G" "MkArr A B F"] by simp
text ‹
The set ‹Obj› of ``objects'' given as a parameter is in bijective correspondence
(via function ‹MkIde›) with the set of identities of the resulting category.
›
proposition bij_betw_ide_Obj:
shows "MkIde ∈ Obj → Collect ide"
and "Dom ∈ Collect ide → Obj"
and "A ∈ Obj ⟹ Dom (MkIde A) = A"
and "a ∈ Collect ide ⟹ MkIde (Dom a) = a"
and "bij_betw Dom (Collect ide) Obj"
proof -
show "MkIde ∈ Obj → Collect ide"
using ide_MkIde by simp
moreover show "Dom ∈ Collect ide → Obj"
using arr_char ideD(1) by simp
moreover show "⋀A. A ∈ Obj ⟹ Dom (MkIde A) = A"
by simp
moreover show "⋀a. a ∈ Collect ide ⟹ MkIde (Dom a) = a"
using MkIde_Dom by simp
ultimately show "bij_betw Dom (Collect ide) Obj"
using bij_betwI by blast
qed
text ‹
For each pair of identities ‹a› and ‹b›, the set ‹Hom (Dom a) (Dom b)› is in
bijective correspondence (via function ‹MkArr (Dom a) (Dom b)›) with the
``hom-set'' ‹hom a b› of the resulting category.
›
proposition bij_betw_hom_Hom:
assumes "ide a" and "ide b"
shows "Map ∈ hom a b → Hom (Dom a) (Dom b)"
and "MkArr (Dom a) (Dom b) ∈ Hom (Dom a) (Dom b) → hom a b"
and "⋀f. f ∈ hom a b ⟹ MkArr (Dom a) (Dom b) (Map f) = f"
and "⋀F. F ∈ Hom (Dom a) (Dom b) ⟹ Map (MkArr (Dom a) (Dom b) F) = F"
and "bij_betw Map (hom a b) (Hom (Dom a) (Dom b))"
proof -
show "Map ∈ hom a b → Hom (Dom a) (Dom b)"
using Map_in_Hom cod_char dom_char in_hom_char by fastforce
moreover show "MkArr (Dom a) (Dom b) ∈ Hom (Dom a) (Dom b) → hom a b"
using assms Dom_in_Obj MkArr_in_hom [of "Dom a" "Dom b"] by simp
moreover show "⋀f. f ∈ hom a b ⟹ MkArr (Dom a) (Dom b) (Map f) = f"
using MkArr_Map by auto
moreover show "⋀F. F ∈ Hom (Dom a) (Dom b)
⟹ Map (MkArr (Dom a) (Dom b) F) = F"
by simp
ultimately show "bij_betw Map (hom a b) (Hom (Dom a) (Dom b))"
using bij_betwI by blast
qed
lemma arr_eqI:
assumes "arr t" and "arr t'" and "Dom t = Dom t'" and "Cod t = Cod t'" and "Map t = Map t'"
shows "t = t'"
using assms MkArr_Map by metis
end
sublocale concrete_category ⊆ category COMP
using is_category by auto
end
Theory FreeCategory
chapter FreeCategory
theory FreeCategory
imports Category ConcreteCategory
begin
text‹
This theory defines locales for constructing the free category generated by
a graph, as well as some special cases, including the discrete category generated
by a set of objects, the ``quiver'' generated by a set of arrows, and a ``parallel pair''
of arrows, which is the diagram shape required for equalizers.
Other diagram shapes can be constructed in a similar fashion.
›
section Graphs
text‹
The following locale gives a definition of graphs in a traditional style.
›
locale graph =
fixes Obj :: "'obj set"
and Arr :: "'arr set"
and Dom :: "'arr ⇒ 'obj"
and Cod :: "'arr ⇒ 'obj"
assumes dom_is_obj: "x ∈ Arr ⟹ Dom x ∈ Obj"
and cod_is_obj: "x ∈ Arr ⟹ Cod x ∈ Obj"
begin
text‹
The list of arrows @{term p} forms a path from object @{term x} to object @{term y}
if the domains and codomains of the arrows match up in the expected way.
›
definition path
where "path x y p ≡ (p = [] ∧ x = y ∧ x ∈ Obj) ∨
(p ≠ [] ∧ x = Dom (hd p) ∧ y = Cod (last p) ∧
(∀n. n ≥ 0 ∧ n < length p ⟶ nth p n ∈ Arr) ∧
(∀n. n ≥ 0 ∧ n < (length p)-1 ⟶ Cod (nth p n) = Dom (nth p (n+1))))"
lemma path_Obj:
assumes "x ∈ Obj"
shows "path x x []"
using assms path_def by simp
lemma path_single_Arr:
assumes "x ∈ Arr"
shows "path (Dom x) (Cod x) [x]"
using assms path_def by simp
lemma path_concat:
assumes "path x y p" and "path y z q"
shows "path x z (p @ q)"
proof -
have "p = [] ∨ q = [] ⟹ ?thesis"
using assms path_def by auto
moreover have "p ≠ [] ∧ q ≠ [] ⟹ ?thesis"
proof -
assume pq: "p ≠ [] ∧ q ≠ []"
have Cod_last: "Cod (last p) = Cod (nth (p @ q) ((length p)-1))"
using assms pq by (simp add: last_conv_nth nth_append)
moreover have Dom_hd: "Dom (hd q) = Dom (nth (p @ q) (length p))"
using assms pq by (simp add: hd_conv_nth less_not_refl2 nth_append)
show ?thesis
proof -
have 1: "⋀n. n ≥ 0 ∧ n < length (p @ q) ⟹ nth (p @ q) n ∈ Arr"
proof -
fix n
assume n: "n ≥ 0 ∧ n < length (p @ q)"
have "(n ≥ 0 ∧ n < length p) ∨ (n ≥ length p ∧ n < length (p @ q))"
using n by auto
thus "nth (p @ q) n ∈ Arr"
using assms pq nth_append path_def le_add_diff_inverse length_append
less_eq_nat.simps(1) nat_add_left_cancel_less
by metis
qed
have 2: "⋀n. n ≥ 0 ∧ n < length (p @ q) - 1 ⟹
Cod (nth (p @ q) n) = Dom (nth (p @ q) (n+1))"
proof -
fix n
assume n: "n ≥ 0 ∧ n < length (p @ q) - 1"
have 1: "(n ≥ 0 ∧ n < (length p) - 1) ∨ (n ≥ length p ∧ n < length (p @ q) - 1)
∨ n = (length p) - 1"
using n by auto
thus "Cod (nth (p @ q) n) = Dom (nth (p @ q) (n+1))"
proof -
have "n ≥ 0 ∧ n < (length p) - 1 ⟹ ?thesis"
using assms pq nth_append path_def by (metis add_lessD1 less_diff_conv)
moreover have "n = (length p) - 1 ⟹ ?thesis"
using assms pq nth_append path_def Dom_hd Cod_last by simp
moreover have "n ≥ length p ∧ n < length (p @ q) - 1 ⟹ ?thesis"
proof -
assume 1: "n ≥ length p ∧ n < length (p @ q) - 1"
have "Cod (nth (p @ q) n) = Cod (nth q (n - length p))"
using 1 nth_append leD by metis
also have "... = Dom (nth q (n - length p + 1))"
using 1 assms(2) path_def by auto
also have "... = Dom (nth (p @ q) (n + 1))"
using 1 nth_append
by (metis Nat.add_diff_assoc2 ex_least_nat_le le_0_eq le_add1 le_neq_implies_less
le_refl le_trans length_0_conv pq)
finally show "Cod (nth (p @ q) n) = Dom (nth (p @ q) (n + 1))" by auto
qed
ultimately show ?thesis using 1 by auto
qed
qed
show ?thesis
unfolding path_def using assms pq path_def hd_append2 Cod_last Dom_hd 1 2
by simp
qed
qed
ultimately show ?thesis by auto
qed
end
section "Free Categories"
text‹
The free category generated by a graph has as its arrows all triples @{term "MkArr x y p"},
where @{term x} and @{term y} are objects and @{term p} is a path from @{term x} to @{term y}.
We construct it here an instance of the general construction given by the
@{locale concrete_category} locale.
›
locale free_category =
G: graph Obj Arr D C
for Obj :: "'obj set"
and Arr :: "'arr set"
and D :: "'arr ⇒ 'obj"
and C :: "'arr ⇒ 'obj"
begin
type_synonym ('o, 'a) arr = "('o, 'a list) concrete_category.arr"
sublocale concrete_category ‹Obj :: 'obj set› ‹λx y. Collect (G.path x y)›
‹λ_. []› ‹λ_ _ _ g f. f @ g›
using G.path_Obj G.path_concat
by (unfold_locales, simp_all)
abbreviation comp (infixr "⋅" 55)
where "comp ≡ COMP"
notation in_hom ("«_ : _ → _»")
abbreviation Path
where "Path ≡ Map"
lemma arr_single [simp]:
assumes "x ∈ Arr"
shows "arr (MkArr (D x) (C x) [x])"
using assms
by (simp add: G.cod_is_obj G.dom_is_obj G.path_single_Arr)
end
section "Discrete Categories"
text‹
A discrete category is a category in which every arrow is an identity.
We could construct it as the free category generated by a graph with no
arrows, but it is simpler just to apply the @{locale concrete_category}
construction directly.
›
locale discrete_category =
fixes Obj :: "'obj set"
begin
type_synonym 'o arr = "('o, unit) concrete_category.arr"
sublocale concrete_category ‹Obj :: 'obj set› ‹λx y. if x = y then {x} else {}›
‹λx. x› ‹λ_ _ x _ _. x›
apply unfold_locales
apply simp_all
apply (metis empty_iff)
apply (metis empty_iff singletonD)
by (metis empty_iff singletonD)
abbreviation comp (infixr "⋅" 55)
where "comp ≡ COMP"
notation in_hom ("«_ : _ → _»")
lemma is_discrete:
shows "arr f ⟷ ide f"
using ide_char arr_char by simp
lemma arr_char:
shows "arr f ⟷ Dom f ∈ Obj ∧ f = MkIde (Dom f)"
using is_discrete
by (metis (no_types, lifting) cod_char dom_char ide_MkIde ide_char ide_char')
lemma arr_char':
shows "arr f ⟷ f ∈ MkIde ` Obj"
using arr_char image_iff by auto
lemma dom_char:
shows "dom f = (if arr f then f else null)"
using dom_char is_discrete by simp
lemma cod_char:
shows "cod f = (if arr f then f else null)"
using cod_char is_discrete by simp
lemma in_hom_char:
shows "«f : a → b» ⟷ arr f ∧ f = a ∧ f = b"
using is_discrete by auto
lemma seq_char:
shows "seq g f ⟷ arr f ∧ f = g"
using is_discrete
by (metis (no_types, lifting) comp_arr_dom seqE dom_char)
lemma comp_char:
shows "g ⋅ f = (if seq g f then f else null)"
proof -
have "¬ seq g f ⟹ ?thesis"
using comp_char by presburger
moreover have "seq g f ⟹ ?thesis"
using seq_char comp_char comp_arr_ide is_discrete
by (metis (no_types, lifting))
ultimately show ?thesis by blast
qed
end
text‹
The empty category is the discrete category generated by an empty set of objects.
›
locale empty_category =
discrete_category "{} :: unit set"
begin
lemma is_empty:
shows "¬arr f"
using arr_char by simp
end
section "Quivers"
text‹
A quiver is a two-object category whose non-identity arrows all point in the
same direction. A quiver is specified by giving the set of these non-identity arrows.
›
locale quiver =
fixes Arr :: "'arr set"
begin
type_synonym 'a arr = "(unit, 'a) concrete_category.arr"
sublocale free_category "{False, True}" Arr "λ_. False" "λ_. True"
by (unfold_locales, simp_all)
notation comp (infixr "⋅" 55)
notation in_hom ("«_ : _ → _»")
definition Zero
where "Zero ≡ MkIde False"
definition One
where "One ≡ MkIde True"
definition fromArr
where "fromArr x ≡ if x ∈ Arr then MkArr False True [x] else null"
definition toArr
where "toArr f ≡ hd (Path f)"
lemma ide_char:
shows "ide f ⟷ f = Zero ∨ f = One"
proof -
have "ide f ⟷ f = MkIde False ∨ f = MkIde True"
using ide_char concrete_category.MkIde_Dom' concrete_category_axioms by fastforce
thus ?thesis
using comp_def Zero_def One_def by simp
qed
lemma arr_char':
shows "arr f ⟷ f =
MkIde False ∨ f = MkIde True ∨ f ∈ (λx. MkArr False True [x]) ` Arr"
proof
assume f: "f = MkIde False ∨ f = MkIde True ∨ f ∈ (λx. MkArr False True [x]) ` Arr"
show "arr f" using f by auto
next
assume f: "arr f"
have "¬(f = MkIde False ∨ f = MkIde True) ⟹ f ∈ (λx. MkArr False True [x]) ` Arr"
proof -
assume f': "¬(f = MkIde False ∨ f = MkIde True)"
have 0: "Dom f = False ∧ Cod f = True"
using f f' arr_char G.path_def MkArr_Map by fastforce
have 1: "f = MkArr False True (Path f)"
using f 0 arr_char MkArr_Map by force
moreover have "length (Path f) = 1"
proof -
have "length (Path f) ≠ 0"
using f f' 0 arr_char G.path_def by simp
moreover have "⋀x y p. length p > 1 ⟹ ¬ G.path x y p"
using G.path_def less_diff_conv by fastforce
ultimately show ?thesis
using f arr_char
by (metis less_one linorder_neqE_nat mem_Collect_eq)
qed
moreover have "⋀p. length p = 1 ⟷ (∃x. p = [x])"
by (auto simp: length_Suc_conv)
ultimately have "∃x. x ∈ Arr ∧ Path f = [x]"
using f G.path_def arr_char
by (metis (no_types, lifting) Cod.simps(1) Dom.simps(1) le_eq_less_or_eq
less_numeral_extra(1) mem_Collect_eq nth_Cons_0)
thus "f ∈ (λx. MkArr False True [x]) ` Arr"
using 1 by auto
qed
thus "f = MkIde False ∨ f = MkIde True ∨ f ∈ (λx. MkArr False True [x]) ` Arr"
by auto
qed
lemma arr_char:
shows "arr f ⟷ f = Zero ∨ f = One ∨ f ∈ fromArr ` Arr"
using arr_char' Zero_def One_def fromArr_def by simp
lemma dom_char:
shows "dom f = (if arr f then
if f = One then One else Zero
else null)"
proof -
have "¬ arr f ⟹ ?thesis"
using dom_char by simp
moreover have "arr f ⟹ ?thesis"
proof -
assume f: "arr f"
have 1: "dom f = MkIde (Dom f)"
using f dom_char by simp
have "f = One ⟹ ?thesis"
using f 1 One_def by (metis (full_types) Dom.simps(1))
moreover have "f = Zero ⟹ ?thesis"
using f 1 Zero_def by (metis (full_types) Dom.simps(1))
moreover have "f ∈ fromArr ` Arr ⟹ ?thesis"
using f fromArr_def G.path_def Zero_def calculation(1) by auto
ultimately show ?thesis
using f arr_char by blast
qed
ultimately show ?thesis by blast
qed
lemma cod_char:
shows "cod f = (if arr f then
if f = Zero then Zero else One
else null)"
proof -
have "¬ arr f ⟹ ?thesis"
using cod_char by simp
moreover have "arr f ⟹ ?thesis"
proof -
assume f: "arr f"
have 1: "cod f = MkIde (Cod f)"
using f cod_char by simp
have "f = One ⟹ ?thesis"
using f 1 One_def by (metis (full_types) Cod.simps(1) f)
moreover have "f = Zero ⟹ ?thesis"
using f 1 Zero_def by (metis (full_types) Cod.simps(1) f)
moreover have "f ∈ fromArr ` Arr ⟹ ?thesis"
using f fromArr_def G.path_def One_def calculation(2) by auto
ultimately show ?thesis
using f arr_char by blast
qed
ultimately show ?thesis by blast
qed
lemma seq_char:
shows "seq g f ⟷ arr g ∧ arr f ∧ ((f = Zero ∧ g ≠ One) ∨ (f ≠ Zero ∧ g = One))"
proof
assume gf: "arr g ∧ arr f ∧ ((f = Zero ∧ g ≠ One) ∨ (f ≠ Zero ∧ g = One))"
show "seq g f"
using gf dom_char cod_char by auto
next
assume gf: "seq g f"
hence 1: "arr f ∧ arr g ∧ dom g = cod f" by auto
have "Cod f = False ⟹ f = Zero"
using gf 1 arr_char [of f] G.path_def Zero_def One_def cod_char Dom_cod
by (metis (no_types, lifting) Dom.simps(1))
moreover have "Cod f = True ⟹ g = One"
using gf 1 arr_char [of f] G.path_def Zero_def One_def dom_char Dom_cod
by (metis (no_types, lifting) Dom.simps(1))
moreover have "¬(f = MkIde False ∧ g = MkIde True)"
using 1 by auto
ultimately show "arr g ∧ arr f ∧ ((f = Zero ∧ g ≠ One) ∨ (f ≠ Zero ∧ g = One))"
using gf arr_char One_def Zero_def by blast
qed
lemma not_ide_fromArr:
shows "¬ ide (fromArr x)"
using fromArr_def ide_char ide_def Zero_def One_def
by (metis Cod.simps(1) Dom.simps(1))
lemma in_hom_char:
shows "«f : a → b» ⟷ (a = Zero ∧ b = Zero ∧ f = Zero) ∨
(a = One ∧ b = One ∧ f = One) ∨
(a = Zero ∧ b = One ∧ f ∈ fromArr ` Arr)"
proof -
have "f = Zero ⟹ ?thesis"
using arr_char' [of f] ide_char'
by (metis (no_types, lifting) Zero_def category.in_homE category.in_homI
cod_MkArr dom_MkArr imageE is_category not_ide_fromArr)
moreover have "f = One ⟹ ?thesis"
using arr_char' [of f] ide_char'
by (metis (no_types, lifting) One_def category.in_homE category.in_homI
cod_MkArr dom_MkArr image_iff is_category not_ide_fromArr)
moreover have "f ∈ fromArr ` Arr ⟹ ?thesis"
proof -
assume f: "f ∈ fromArr ` Arr"
have 1: "arr f" using f arr_char by simp
moreover have "dom f = Zero ∧ cod f = One"
using f 1 arr_char dom_char cod_char fromArr_def
by (metis (no_types, lifting) ide_char imageE not_ide_fromArr)
ultimately have "in_hom f Zero One" by auto
thus "in_hom f a b ⟷ (a = Zero ∧ b = Zero ∧ f = Zero ∨
a = One ∧ b = One ∧ f = One ∨
a = Zero ∧ b = One ∧ f ∈ fromArr ` Arr)"
using f ide_char by auto
qed
ultimately show ?thesis
using arr_char [of f] by fast
qed
lemma Zero_not_eq_One [simp]:
shows "Zero ≠ One"
by (simp add: One_def Zero_def)
lemma Zero_not_eq_fromArr [simp]:
shows "Zero ∉ fromArr ` Arr"
using ide_char not_ide_fromArr
by (metis (no_types, lifting) image_iff)
lemma One_not_eq_fromArr [simp]:
shows "One ∉ fromArr ` Arr"
using ide_char not_ide_fromArr
by (metis (no_types, lifting) image_iff)
lemma comp_char:
shows "g ⋅ f = (if seq g f then
if f = Zero then g else if g = One then f else null
else null)"
proof -
have "seq g f ⟹ f = Zero ⟹ g ⋅ f = g"
using seq_char comp_char [of g f] Zero_def dom_char cod_char comp_arr_dom
by auto
moreover have "seq g f ⟹ g = One ⟹ g ⋅ f = f"
using seq_char comp_char [of g f] One_def dom_char cod_char comp_cod_arr
by simp
moreover have "seq g f ⟹ f ≠ Zero ⟹ g ≠ One ⟹ g ⋅ f = null"
using seq_char Zero_def One_def by simp
moreover have "¬seq g f ⟹ g ⋅ f = null"
using comp_char ext by fastforce
ultimately show ?thesis by argo
qed
lemma comp_simp [simp]:
assumes "seq g f"
shows "f = Zero ⟹ g ⋅ f = g"
and "g = One ⟹ g ⋅ f = f"
using assms seq_char comp_char by metis+
lemma arr_fromArr:
assumes "x ∈ Arr"
shows "arr (fromArr x)"
using assms fromArr_def arr_char image_eqI by simp
lemma toArr_in_Arr:
assumes "arr f" and "¬ide f"
shows "toArr f ∈ Arr"
proof -
have "⋀a. a ∈ Arr ⟹ Path (fromArr a) = [a]"
using fromArr_def arr_char by simp
hence "hd (Path f) ∈ Arr"
using assms arr_char ide_char by auto
thus ?thesis
by (simp add: toArr_def)
qed
lemma toArr_fromArr [simp]:
assumes "x ∈ Arr"
shows "toArr (fromArr x) = x"
using assms fromArr_def toArr_def
by (simp add: toArr_def)
lemma fromArr_toArr [simp]:
assumes "arr f" and "¬ide f"
shows "fromArr (toArr f) = f"
using assms fromArr_def toArr_def arr_char ide_char toArr_fromArr by auto
end
section "Parallel Pairs"
text‹
A parallel pair is a quiver with two non-identity arrows.
It is important in the definition of equalizers.
›
locale parallel_pair =
quiver "{False, True} :: bool set"
begin
typedef arr = "UNIV :: bool quiver.arr set" ..
definition j0
where "j0 ≡ fromArr False"
definition j1
where "j1 ≡ fromArr True"
lemma arr_char:
shows "arr f ⟷ f = Zero ∨ f = One ∨ f = j0 ∨ f = j1"
using arr_char j0_def j1_def by simp
lemma dom_char:
shows "dom f = (if f = j0 ∨ f = j1 then Zero else if arr f then f else null)"
using arr_char dom_char j0_def j1_def
by (metis ide_char not_ide_fromArr)
lemma cod_char:
shows "cod f = (if f = j0 ∨ f = j1 then One else if arr f then f else null)"
using arr_char cod_char j0_def j1_def
by (metis ide_char not_ide_fromArr)
lemma j0_not_eq_j1 [simp]:
shows "j0 ≠ j1"
using j0_def j1_def
by (metis insert_iff toArr_fromArr)
lemma Zero_not_eq_j0 [simp]:
shows "Zero ≠ j0"
using Zero_def j0_def Zero_not_eq_fromArr by auto
lemma Zero_not_eq_j1 [simp]:
shows "Zero ≠ j1"
using Zero_def j1_def Zero_not_eq_fromArr by auto
lemma One_not_eq_j0 [simp]:
shows "One ≠ j0"
using One_def j0_def One_not_eq_fromArr by auto
lemma One_not_eq_j1 [simp]:
shows "One ≠ j1"
using One_def j1_def One_not_eq_fromArr by auto
lemma dom_simp [simp]:
shows "dom Zero = Zero"
and "dom One = One"
and "dom j0 = Zero"
and "dom j1 = Zero"
using dom_char arr_char by auto
lemma cod_simp [simp]:
shows "cod Zero = Zero"
and "cod One = One"
and "cod j0 = One"
and "cod j1 = One"
using cod_char arr_char by auto
end
end
Theory DiscreteCategory
chapter DiscreteCategory
theory DiscreteCategory
imports Category
begin
text‹
The locale defined here permits us to construct a discrete category having
a specified set of objects, assuming that the set does not exhaust the elements
of its type. In that case, we have the convenient situation that the arrows of
the category can be directly identified with the elements of the given set,
rather than having to pass between the two via tedious coercion maps.
If it cannot be guaranteed that the given set is not the universal set at its type,
then the more general discrete category construction defined (using coercions)
in ‹FreeCategory› can be used.
›
locale discrete_category =
fixes Obj :: "'a set"
and Null :: 'a
assumes Null_not_in_Obj: "Null ∉ Obj"
begin
definition comp :: "'a comp" (infixr "⋅" 55)
where "y ⋅ x ≡ (if x ∈ Obj ∧ x = y then x else Null)"
interpretation partial_magma comp
apply unfold_locales
using comp_def by metis
lemma null_char:
shows "null = Null"
using comp_def null_def by auto
lemma ide_char [iff]:
shows "ide f ⟷ f ∈ Obj"
using comp_def null_char ide_def Null_not_in_Obj by auto
lemma domains_char:
shows "domains f = {x. x ∈ Obj ∧ x = f}"
unfolding domains_def
using ide_char ide_def comp_def null_char by metis
theorem is_category:
shows "category comp"
using comp_def
apply unfold_locales
using arr_def null_char self_domain_iff_ide ide_char
apply fastforce
using null_char self_codomain_iff_ide domains_char codomains_def ide_char
apply fastforce
apply (metis not_arr_null null_char)
apply (metis not_arr_null null_char)
by auto
end
sublocale discrete_category ⊆ category comp
using is_category by auto
context discrete_category
begin
lemma arr_char [iff]:
shows "arr f ⟷ f ∈ Obj"
using comp_def comp_cod_arr
by (metis empty_iff has_codomain_iff_arr not_arr_null null_char self_codomain_iff_ide ide_char)
lemma dom_char [simp]:
shows "dom f = (if f ∈ Obj then f else null)"
using arr_def dom_def arr_char ideD(2) by auto
lemma cod_char [simp]:
shows "cod f = (if f ∈ Obj then f else null)"
using arr_def in_homE cod_def ideD(3) by auto
lemma comp_char [simp]:
shows "comp g f = (if f ∈ Obj ∧ f = g then f else null)"
using comp_def null_char by auto
lemma is_discrete:
shows "ide = arr"
using arr_char ide_char by auto
lemma seq_char [iff]:
shows "seq f g ⟷ ide f ∧ f = g"
using is_discrete by (metis (full_types) ide_def seqE)
end
end
Theory DualCategory
chapter DualCategory
theory DualCategory
imports Category
begin
text‹
The locale defined here constructs the dual (opposite) of a category.
The arrows of the dual category are directly identified with the arrows of
the given category and simplification rules are introduced that automatically
eliminate notions defined for the dual category in favor of the corresponding
notions on the original category. This makes it easy to use the dual of
a category in the same context as the category itself, without having to
worry about whether an arrow belongs to the category or its dual.
›
locale dual_category =
C: category C
for C :: "'a comp" (infixr "⋅" 55)
begin
definition comp (infixr "⋅⇧o⇧p" 55)
where "g ⋅⇧o⇧p f ≡ f ⋅ g"
lemma comp_char [simp]:
shows "g ⋅⇧o⇧p f = f ⋅ g"
using comp_def by auto
interpretation partial_magma comp
apply unfold_locales using comp_def C.ex_un_null by metis
notation in_hom ("«_ : _ ← _»")
lemma null_char [simp]:
shows "null = C.null"
by (metis C.comp_null(2) comp_null(2) comp_def)
lemma ide_char [simp]:
shows "ide a ⟷ C.ide a"
unfolding ide_def C.ide_def by auto
lemma domains_char:
shows "domains f = C.codomains f"
using C.codomains_def domains_def ide_char by auto
lemma codomains_char:
shows "codomains f = C.domains f"
using C.domains_def codomains_def ide_char by auto
interpretation category comp
using C.has_domain_iff_arr C.has_codomain_iff_arr domains_char codomains_char null_char
comp_def C.match_4 C.ext arr_def C.comp_assoc
apply (unfold_locales, auto)
using C.match_2 by metis
lemma is_category:
shows "category comp" ..
end
sublocale dual_category ⊆ category comp
using is_category by auto
context dual_category
begin
lemma dom_char [simp]:
shows "dom f = C.cod f"
by (simp add: C.cod_def dom_def domains_char)
lemma cod_char [simp]:
shows "cod f = C.dom f"
by (simp add: C.dom_def cod_def codomains_char)
lemma arr_char [simp]:
shows "arr f ⟷ C.arr f"
using C.has_codomain_iff_arr has_domain_iff_arr domains_char by auto
lemma hom_char [simp]:
shows "in_hom f b a ⟷ C.in_hom f a b"
by force
lemma seq_char [simp]:
shows "seq g f = C.seq f g"
by simp
end
end
Theory EpiMonoIso
chapter EpiMonoIso
theory EpiMonoIso
imports Category
begin
text‹
This theory defines and develops properties of epimorphisms, monomorphisms,
isomorphisms, sections, and retractions.
›
context category
begin
definition epi
where "epi f = (arr f ∧ inj_on (λg. g ⋅ f) {g. seq g f})"
definition mono
where "mono f = (arr f ∧ inj_on (λg. f ⋅ g) {g. seq f g})"
lemma epiI [intro]:
assumes "arr f" and "⋀g g'. seq g f ∧ seq g' f ∧ g ⋅ f = g' ⋅ f ⟹ g = g'"
shows "epi f"
using assms epi_def inj_on_def by blast
lemma epi_implies_arr:
assumes "epi f"
shows "arr f"
using assms epi_def by auto
lemma epiE [elim]:
assumes "epi f"
and "seq g f" and "seq g' f" and "g ⋅ f = g' ⋅ f"
shows "g = g'"
using assms unfolding epi_def inj_on_def by blast
lemma monoI [intro]:
assumes "arr g" and "⋀f f'. seq g f ∧ seq g f' ∧ g ⋅ f = g ⋅ f' ⟹ f = f'"
shows "mono g"
using assms mono_def inj_on_def by blast
lemma mono_implies_arr:
assumes "mono f"
shows "arr f"
using assms mono_def by auto
lemma monoE [elim]:
assumes "mono g"
and "seq g f" and "seq g f'" and "g ⋅ f = g ⋅ f'"
shows "f' = f"
using assms unfolding mono_def inj_on_def by blast
definition inverse_arrows
where "inverse_arrows f g ≡ ide (g ⋅ f) ∧ ide (f ⋅ g)"
lemma inverse_arrowsI [intro]:
assumes "ide (g ⋅ f)" and "ide (f ⋅ g)"
shows "inverse_arrows f g"
using assms inverse_arrows_def by blast
lemma inverse_arrowsE [elim]:
assumes "inverse_arrows f g"
and "⟦ ide (g ⋅ f); ide (f ⋅ g) ⟧ ⟹ T"
shows "T"
using assms inverse_arrows_def by blast
lemma inverse_arrows_sym:
shows "inverse_arrows f g ⟷ inverse_arrows g f"
using inverse_arrows_def by auto
lemma ide_self_inverse:
assumes "ide a"
shows "inverse_arrows a a"
using assms by auto
lemma inverse_arrow_unique:
assumes "inverse_arrows f g" and "inverse_arrows f g'"
shows "g = g'"
using assms apply (elim inverse_arrowsE)
by (metis comp_cod_arr ide_compE comp_assoc seqE)
lemma inverse_arrows_compose:
assumes "seq g f" and "inverse_arrows f f'" and "inverse_arrows g g'"
shows "inverse_arrows (g ⋅ f) (f' ⋅ g')"
using assms apply (elim inverse_arrowsE, intro inverse_arrowsI)
apply (metis seqE comp_arr_dom ide_compE comp_assoc)
by (metis seqE comp_arr_dom ide_compE comp_assoc)
definition "section"
where "section f ≡ ∃g. ide (g ⋅ f)"
lemma sectionI [intro]:
assumes "ide (g ⋅ f)"
shows "section f"
using assms section_def by auto
lemma sectionE [elim]:
assumes "section f"
obtains g where "ide (g ⋅ f)"
using assms section_def by blast
definition retraction
where "retraction g ≡ ∃f. ide (g ⋅ f)"
lemma retractionI [intro]:
assumes "ide (g ⋅ f)"
shows "retraction g"
using assms retraction_def by auto
lemma retractionE [elim]:
assumes "retraction g"
obtains f where "ide (g ⋅ f)"
using assms retraction_def by blast
lemma section_is_mono:
assumes "section g"
shows "mono g"
proof
show "arr g" using assms section_def by blast
from assms obtain h where h: "ide (h ⋅ g)" by blast
have hg: "seq h g" using h by auto
fix f f'
assume "seq g f ∧ seq g f' ∧ g ⋅ f = g ⋅ f'"
thus "f = f'"
using hg h ide_compE seqE comp_assoc comp_cod_arr by metis
qed
lemma retraction_is_epi:
assumes "retraction g"
shows "epi g"
proof
show "arr g" using assms retraction_def by blast
from assms obtain f where f: "ide (g ⋅ f)" by blast
have gf: "seq g f" using f by auto
fix h h'
assume "seq h g ∧ seq h' g ∧ h ⋅ g = h' ⋅ g"
thus "h = h'"
using gf f ide_compE seqE comp_assoc comp_arr_dom by metis
qed
lemma section_retraction_compose:
assumes "ide (e ⋅ m)" and "ide (e' ⋅ m')" and "seq m' m"
shows "ide ((e ⋅ e') ⋅ (m' ⋅ m))"
using assms seqI seqE ide_compE comp_assoc comp_arr_dom by metis
lemma sections_compose [intro]:
assumes "section m" and "section m'" and "seq m' m"
shows "section (m' ⋅ m)"
using assms section_def section_retraction_compose by metis
lemma retractions_compose [intro]:
assumes "retraction e" and "retraction e'" and "seq e' e"
shows "retraction (e' ⋅ e)"
proof -
from assms(1-2) obtain m m'
where *: "ide (e ⋅ m) ∧ ide (e' ⋅ m')"
using retraction_def by auto
hence "seq m m'"
using assms(3) by (metis seqE seqI ide_compE)
with * show ?thesis
using section_retraction_compose retractionI by blast
qed
lemma monos_compose [intro]:
assumes "mono m" and "mono m'" and "seq m' m"
shows "mono (m' ⋅ m)"
proof -
have "inj_on (λf. (m' ⋅ m) ⋅ f) {f. seq (m' ⋅ m) f}"
unfolding inj_on_def
using assms
by (metis CollectD seqE monoE comp_assoc)
thus ?thesis using assms(3) mono_def by force
qed
lemma epis_compose [intro]:
assumes "epi e" and "epi e'" and "seq e' e"
shows "epi (e' ⋅ e)"
proof -
have "inj_on (λg. g ⋅ (e' ⋅ e)) {g. seq g (e' ⋅ e)}"
unfolding inj_on_def
using assms by (metis CollectD epiE match_2 comp_assoc)
thus ?thesis using assms(3) epi_def by force
qed
definition iso
where "iso f ≡ ∃g. inverse_arrows f g"
lemma isoI [intro]:
assumes "inverse_arrows f g"
shows "iso f"
using assms iso_def by auto
lemma isoE [elim]:
assumes "iso f"
obtains g where "inverse_arrows f g"
using assms iso_def by blast
lemma ide_is_iso [simp]:
assumes "ide a"
shows "iso a"
using assms ide_self_inverse by auto
lemma iso_is_arr:
assumes "iso f"
shows "arr f"
using assms by blast
lemma iso_is_section:
assumes "iso f"
shows "section f"
using assms inverse_arrows_def by blast
lemma iso_is_retraction:
assumes "iso f"
shows "retraction f"
using assms inverse_arrows_def by blast
lemma iso_iff_mono_and_retraction:
shows "iso f ⟷ mono f ∧ retraction f"
proof
show "iso f ⟹ mono f ∧ retraction f"
by (simp add: iso_is_retraction iso_is_section section_is_mono)
show "mono f ∧ retraction f ⟹ iso f"
proof -
assume f: "mono f ∧ retraction f"
from f obtain g where g: "ide (f ⋅ g)" by blast
have "inverse_arrows f g"
using f g comp_arr_dom comp_cod_arr comp_assoc inverse_arrowsI
by (metis ide_char' ide_compE monoE mono_implies_arr)
thus "iso f" by auto
qed
qed
lemma iso_iff_section_and_epi:
shows "iso f ⟷ section f ∧ epi f"
proof
show "iso f ⟹ section f ∧ epi f"
by (simp add: iso_is_retraction iso_is_section retraction_is_epi)
show "section f ∧ epi f ⟹ iso f"
proof -
assume f: "section f ∧ epi f"
from f obtain g where g: "ide (g ⋅ f)" by blast
have "inverse_arrows f g"
using f g comp_arr_dom comp_cod_arr epi_implies_arr
comp_assoc ide_compE inverse_arrowsI epiE ide_char'
by metis
thus "iso f" by auto
qed
qed
lemma iso_iff_section_and_retraction:
shows "iso f ⟷ section f ∧ retraction f"
using iso_is_retraction iso_is_section iso_iff_mono_and_retraction section_is_mono
by auto
lemma isos_compose [intro]:
assumes "iso f" and "iso f'" and "seq f' f"
shows "iso (f' ⋅ f)"
proof -
from assms(1) obtain g where g: "inverse_arrows f g" by blast
from assms(2) obtain g' where g': "inverse_arrows f' g'" by blast
have "inverse_arrows (f' ⋅ f) (g ⋅ g')"
using assms g g inverse_arrowsI inverse_arrowsE section_retraction_compose
by (simp add: g' inverse_arrows_compose)
thus ?thesis using iso_def by auto
qed
lemma iso_cancel_left:
assumes "iso f" and "f ⋅ g = f ⋅ g'" and "seq f g"
shows "g = g'"
using assms iso_is_section section_is_mono monoE by metis
lemma iso_cancel_right:
assumes "iso g" and "f ⋅ g = f' ⋅ g" and "seq f g" and "iso g"
shows "f = f'"
using assms iso_is_retraction retraction_is_epi epiE by metis
definition isomorphic
where "isomorphic a a' = (∃f. «f : a → a'» ∧ iso f)"
lemma isomorphicI [intro]:
assumes "iso f"
shows "isomorphic (dom f) (cod f)"
using assms isomorphic_def iso_is_arr by blast
lemma isomorphicE [elim]:
assumes "isomorphic a a'"
obtains f where "«f : a → a'» ∧ iso f"
using assms isomorphic_def by meson
definition iso_in_hom ("«_ : _ ≅ _»")
where "iso_in_hom f a b ≡ «f : a → b» ∧ iso f"
lemma iso_in_homI [intro]:
assumes "«f : a → b»" and "iso f"
shows "«f : a ≅ b»"
using assms iso_in_hom_def by simp
lemma iso_in_homE [elim]:
assumes "«f : a ≅ b»"
and "⟦«f : a → b»; iso f⟧ ⟹ T"
shows T
using assms iso_in_hom_def by simp
lemma isomorphicI':
assumes "«f : a ≅ b»"
shows "isomorphic a b"
using assms iso_in_hom_def isomorphic_def by auto
lemma ide_iso_in_hom:
assumes "ide a"
shows "«a : a ≅ a»"
using assms by fastforce
lemma comp_iso_in_hom [intro]:
assumes "«f : a ≅ b»" and "«g : b ≅ c»"
shows "«g ⋅ f : a ≅ c»"
using assms iso_in_hom_def by auto
definition inv
where "inv f = (SOME g. inverse_arrows f g)"
lemma inv_is_inverse:
assumes "iso f"
shows "inverse_arrows f (inv f)"
using assms inv_def someI [of "inverse_arrows f"] by auto
lemma iso_inv_iso [intro, simp]:
assumes "iso f"
shows "iso (inv f)"
using assms inv_is_inverse inverse_arrows_sym by blast
lemma inverse_unique:
assumes "inverse_arrows f g"
shows "inv f = g"
using assms inv_is_inverse inverse_arrow_unique isoI by auto
lemma inv_ide [simp]:
assumes "ide a"
shows "inv a = a"
using assms by (simp add: inverse_arrowsI inverse_unique)
lemma inv_inv [simp]:
assumes "iso f"
shows "inv (inv f) = f"
using assms inverse_arrows_sym inverse_unique by blast
lemma comp_arr_inv:
assumes "inverse_arrows f g"
shows "f ⋅ g = dom g"
using assms by auto
lemma comp_inv_arr:
assumes "inverse_arrows f g"
shows "g ⋅ f = dom f"
using assms by auto
lemma comp_arr_inv':
assumes "iso f"
shows "f ⋅ inv f = cod f"
using assms inv_is_inverse by blast
lemma comp_inv_arr':
assumes "iso f"
shows "inv f ⋅ f = dom f"
using assms inv_is_inverse by blast
lemma inv_in_hom [simp]:
assumes "iso f" and "«f : a → b»"
shows "«inv f : b → a»"
using assms inv_is_inverse seqE inverse_arrowsE
by (metis ide_compE in_homE in_homI)
lemma arr_inv [simp]:
assumes "iso f"
shows "arr (inv f)"
using assms inv_in_hom by blast
lemma dom_inv [simp]:
assumes "iso f"
shows "dom (inv f) = cod f"
using assms inv_in_hom by blast
lemma cod_inv [simp]:
assumes "iso f"
shows "cod (inv f) = dom f"
using assms inv_in_hom by blast
lemma inv_comp:
assumes "iso f" and "iso g" and "seq g f"
shows "inv (g ⋅ f) = inv f ⋅ inv g"
using assms inv_is_inverse inverse_unique inverse_arrows_compose inverse_arrows_def
by meson
lemma isomorphic_reflexive:
assumes "ide f"
shows "isomorphic f f"
unfolding isomorphic_def
using assms ide_is_iso ide_in_hom by blast
lemma isomorphic_symmetric:
assumes "isomorphic f g"
shows "isomorphic g f"
using assms inv_in_hom by blast
lemma isomorphic_transitive [trans]:
assumes "isomorphic f g" and "isomorphic g h"
shows "isomorphic f h"
using assms isomorphic_def isos_compose by auto
text ‹
A section or retraction of an isomorphism is in fact an inverse.
›
lemma section_retraction_of_iso:
assumes "iso f"
shows "ide (g ⋅ f) ⟹ inverse_arrows f g"
and "ide (f ⋅ g) ⟹ inverse_arrows f g"
proof -
show "ide (g ⋅ f) ⟹ inverse_arrows f g"
using assms
by (metis comp_inv_arr' epiE ide_compE inv_is_inverse iso_iff_section_and_epi)
show "ide (f ⋅ g) ⟹ inverse_arrows f g"
using assms
by (metis ide_compE comp_arr_inv' inv_is_inverse iso_iff_mono_and_retraction monoE)
qed
text ‹
A situation that occurs frequently is that we have a commuting triangle,
but we need the triangle obtained by inverting one side that is an isomorphism.
The following fact streamlines this derivation.
›
lemma invert_side_of_triangle:
assumes "arr h" and "f ⋅ g = h"
shows "iso f ⟹ seq (inv f) h ∧ g = inv f ⋅ h"
and "iso g ⟹ seq h (inv g) ∧ f = h ⋅ inv g"
proof -
show "iso f ⟹ seq (inv f) h ∧ g = inv f ⋅ h"
by (metis assms seqE inv_is_inverse comp_cod_arr comp_inv_arr comp_assoc)
show "iso g ⟹ seq h (inv g) ∧ f = h ⋅ inv g"
by (metis assms seqE inv_is_inverse comp_arr_dom comp_arr_inv dom_inv comp_assoc)
qed
text ‹
A similar situation is where we have a commuting square and we want to
invert two opposite sides.
›
lemma invert_opposite_sides_of_square:
assumes "seq f g" and "f ⋅ g = h ⋅ k"
shows "⟦ iso f; iso k ⟧ ⟹ seq g (inv k) ∧ seq (inv f) h ∧ g ⋅ inv k = inv f ⋅ h"
by (metis assms invert_side_of_triangle comp_assoc)
text ‹
The following versions of ‹inv_comp› provide information needed for repeated
application to a composition of more than two arrows and seem often to be more
useful.
›
lemma inv_comp_left:
assumes "iso (g ⋅ f)" and "iso g"
shows "inv (g ⋅ f) = inv f ⋅ inv g" and "iso f"
proof -
have 1: "inv f = inv (g ⋅ f) ⋅ g"
proof -
have "inv (g ⋅ f) ⋅ g = inv (g ⋅ f) ⋅ inv (inv g)"
using assms by simp
also have "... = inv (inv g ⋅ g ⋅ f)"
using assms inv_comp iso_is_arr by simp
also have "... = inv ((inv g ⋅ g) ⋅ f)"
using comp_assoc by simp
also have "... = inv f"
using assms comp_ide_arr invert_side_of_triangle(1) iso_is_arr comp_assoc
by metis
finally show ?thesis by simp
qed
show "inv (g ⋅ f) = inv f ⋅ inv g"
using assms 1 comp_arr_dom comp_assoc
by (metis arr_inv cod_comp dom_inv invert_side_of_triangle(2) iso_is_arr seqI)
show "iso f"
using assms 1 comp_assoc inv_is_inverse
by (metis arr_inv invert_side_of_triangle(1) inv_inv iso_inv_iso isos_compose)
qed
lemma inv_comp_right:
assumes "iso (g ⋅ f)" and "iso f"
shows "inv (g ⋅ f) = inv f ⋅ inv g" and "iso g"
proof -
have 1: "inv g = f ⋅ inv (g ⋅ f)"
proof -
have "f ⋅ inv (g ⋅ f) = inv (inv f) ⋅ inv (g ⋅ f)"
using assms by simp
also have "... = inv ((g ⋅ f) ⋅ inv f)"
using assms inv_comp iso_is_arr by simp
also have "... = inv (g ⋅ f ⋅ inv f)"
using comp_assoc by simp
also have "... = inv g"
using assms comp_arr_dom invert_side_of_triangle(2) iso_is_arr comp_assoc
by metis
finally show ?thesis by simp
qed
show "inv (g ⋅ f) = inv f ⋅ inv g"
using assms 1 comp_cod_arr comp_assoc
by (metis arr_inv cod_inv dom_comp seqI invert_side_of_triangle(1) iso_is_arr)
show "iso g"
using assms 1 comp_assoc inv_is_inverse
by (metis arr_inv invert_side_of_triangle(2) inv_inv iso_inv_iso isos_compose)
qed
end
end
Theory InitialTerminal
chapter InitialTerminal
theory InitialTerminal
imports EpiMonoIso
begin
text‹
This theory defines the notions of initial and terminal object in a category
and establishes some properties of these notions, including that when they exist
they are unique up to isomorphism.
›
context category
begin
definition initial
where "initial a ≡ ide a ∧ (∀b. ide b ⟶ (∃!f. «f : a → b»))"
definition terminal
where "terminal b ≡ ide b ∧ (∀a. ide a ⟶ (∃!f. «f : a → b»))"
abbreviation initial_arr
where "initial_arr f ≡ arr f ∧ initial (dom f)"
abbreviation terminal_arr
where "terminal_arr f ≡ arr f ∧ terminal (cod f)"
abbreviation point
where "point f ≡ arr f ∧ terminal (dom f)"
lemma initial_arr_unique:
assumes "par f f'" and "initial_arr f" and "initial_arr f'"
shows "f = f'"
using assms in_homI initial_def ide_cod by blast
lemma initialI [intro]:
assumes "ide a" and "⋀b. ide b ⟹ ∃!f. «f : a → b»"
shows "initial a"
using assms initial_def by auto
lemma initialE [elim]:
assumes "initial a" and "ide b"
obtains f where "«f : a → b»" and "⋀f'. «f' : a → b» ⟹ f' = f"
using assms initial_def initial_arr_unique by meson
lemma terminal_arr_unique:
assumes "par f f'" and "terminal_arr f" and "terminal_arr f'"
shows "f = f'"
using assms in_homI terminal_def ide_dom by blast
lemma terminalI [intro]:
assumes "ide b" and "⋀a. ide a ⟹ ∃!f. «f : a → b»"
shows "terminal b"
using assms terminal_def by auto
lemma terminalE [elim]:
assumes "terminal b" and "ide a"
obtains f where "«f : a → b»" and "⋀f'. «f' : a → b» ⟹ f' = f"
using assms terminal_def terminal_arr_unique by meson
theorem terminal_objs_isomorphic:
assumes "terminal a" and "terminal b"
shows "isomorphic a b"
proof -
from assms obtain f where f: "«f : a → b»"
using terminal_def by meson
from assms obtain g where g: "«g : b → a»"
using terminal_def by meson
have "iso f"
using assms f g
by (metis arr_iff_in_hom cod_comp retractionI sectionI seqI' terminal_def
dom_comp in_homE iso_iff_section_and_retraction ide_in_hom)
thus ?thesis using f by auto
qed
theorem initial_objs_isomorphic:
assumes "initial a" and "initial b"
shows "isomorphic a b"
proof -
from assms obtain f where f: "«f : a → b»" using initial_def by auto
from assms obtain g where g: "«g : b → a»" using initial_def by auto
have "iso f"
using assms f g
by (metis (no_types, lifting) arr_iff_in_hom cod_comp in_homE initial_def
retractionI sectionI dom_comp iso_iff_section_and_retraction ide_in_hom seqI')
thus ?thesis
using f by auto
qed
lemma point_is_mono:
assumes "point f"
shows "mono f"
proof -
have "ide (cod f)" using assms by auto
from this obtain t where t: "«t: cod f → dom f»"
using assms terminal_def by blast
thus ?thesis
using assms terminal_def monoI
by (metis seqE in_homI dom_comp ide_dom terminal_def)
qed
end
end
Theory Functor
chapter Functor
theory Functor
imports Category ConcreteCategory DualCategory InitialTerminal
begin
text‹
One advantage of the ``object-free'' definition of category is that a functor
from category ‹A› to category ‹B› is simply a function from the type
of arrows of ‹A› to the type of arrows of ‹B› that satisfies certain
conditions: namely, that arrows are mapped to arrows, non-arrows are mapped to
‹null›, and domains, codomains, and composition of arrows are preserved.
›
locale "functor" =
A: category A +
B: category B
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and F :: "'a ⇒ 'b" +
assumes is_extensional: "¬A.arr f ⟹ F f = B.null"
and preserves_arr: "A.arr f ⟹ B.arr (F f)"
and preserves_dom [iff]: "A.arr f ⟹ B.dom (F f) = F (A.dom f)"
and preserves_cod [iff]: "A.arr f ⟹ B.cod (F f) = F (A.cod f)"
and preserves_comp [iff]: "A.seq g f ⟹ F (g ⋅⇩A f) = F g ⋅⇩B F f"
begin
notation A.in_hom ("«_ : _ →⇩A _»")
notation B.in_hom ("«_ : _ →⇩B _»")
lemma preserves_hom [intro]:
assumes "«f : a →⇩A b»"
shows "«F f : F a →⇩B F b»"
using assms B.in_homI
by (metis A.in_homE preserves_arr preserves_cod preserves_dom)
text‹
The following, which is made possible through the presence of ‹null›,
allows us to infer that the subterm @{term f} denotes an arrow if the
term @{term "F f"} denotes an arrow. This is very useful, because otherwise
doing anything with @{term f} would require a separate proof that it is an arrow
by some other means.
›
lemma preserves_reflects_arr [iff]:
shows "B.arr (F f) ⟷ A.arr f"
using preserves_arr is_extensional B.not_arr_null by metis
lemma preserves_seq [intro]:
assumes "A.seq g f"
shows "B.seq (F g) (F f)"
using assms by auto
lemma preserves_ide [simp]:
assumes "A.ide a"
shows "B.ide (F a)"
using assms A.ide_in_hom B.ide_in_hom by auto
lemma preserves_iso [simp]:
assumes "A.iso f"
shows "B.iso (F f)"
using assms A.inverse_arrowsE
apply (elim A.isoE A.inverse_arrowsE A.seqE A.ide_compE)
by (metis A.arr_dom_iff_arr B.ide_dom B.inverse_arrows_def B.isoI preserves_arr
preserves_comp preserves_dom)
lemma preserves_section_retraction:
assumes "A.ide (A e m)"
shows "B.ide (B (F e) (F m))"
using assms by (metis A.ide_compE preserves_comp preserves_ide)
lemma preserves_section:
assumes "A.section m"
shows "B.section (F m)"
using assms preserves_section_retraction by blast
lemma preserves_retraction:
assumes "A.retraction e"
shows "B.retraction (F e)"
using assms preserves_section_retraction by blast
lemma preserves_inverse_arrows:
assumes "A.inverse_arrows f g"
shows "B.inverse_arrows (F f) (F g)"
using assms A.inverse_arrows_def B.inverse_arrows_def preserves_section_retraction
by simp
lemma preserves_inv:
assumes "A.iso f"
shows "F (A.inv f) = B.inv (F f)"
using assms preserves_inverse_arrows A.inv_is_inverse B.inv_is_inverse
B.inverse_arrow_unique
by blast
lemma preserves_iso_in_hom [intro]:
assumes "A.iso_in_hom f a b"
shows "B.iso_in_hom (F f) (F a) (F b)"
using assms preserves_hom preserves_iso by blast
end
locale endofunctor =
"functor" A A F
for A :: "'a comp" (infixr "⋅" 55)
and F :: "'a ⇒ 'a"
locale faithful_functor = "functor" A B F
for A :: "'a comp"
and B :: "'b comp"
and F :: "'a ⇒ 'b" +
assumes is_faithful: "⟦ A.par f f'; F f = F f' ⟧ ⟹ f = f'"
begin
lemma locally_reflects_ide:
assumes "«f : a →⇩A a»" and "B.ide (F f)"
shows "A.ide f"
using assms is_faithful
by (metis A.arr_dom_iff_arr A.cod_dom A.dom_dom A.in_homE B.comp_ide_self
B.ide_self_inverse B.comp_arr_inv A.ide_cod preserves_dom)
end
locale full_functor = "functor" A B F
for A :: "'a comp"
and B :: "'b comp"
and F :: "'a ⇒ 'b" +
assumes is_full: "⟦ A.ide a; A.ide a'; «g : F a' →⇩B F a» ⟧ ⟹ ∃f. «f : a' →⇩A a» ∧ F f = g"
locale fully_faithful_functor =
faithful_functor A B F +
full_functor A B F
for A :: "'a comp"
and B :: "'b comp"
and F :: "'a ⇒ 'b"
begin
lemma reflects_iso:
assumes "«f : a' →⇩A a»" and "B.iso (F f)"
shows "A.iso f"
proof -
from assms obtain g' where g': "B.inverse_arrows (F f) g'" by blast
have 1: "«g' : F a →⇩B F a'»"
using assms g' by (metis B.inv_in_hom B.inverse_unique preserves_hom)
from this obtain g where g: "«g : a →⇩A a'» ∧ F g = g'"
using assms(1) is_full by (metis A.arrI A.ide_cod A.ide_dom A.in_homE)
have "A.inverse_arrows f g"
using assms 1 g g' A.inverse_arrowsI
by (metis A.arr_iff_in_hom A.dom_comp A.in_homE A.seqI' B.inverse_arrowsE
A.cod_comp locally_reflects_ide preserves_comp)
thus ?thesis by auto
qed
lemma reflects_isomorphic:
assumes "A.ide f" and "A.ide f'" and "B.isomorphic (F f) (F f')"
shows "A.isomorphic f f'"
proof -
obtain ψ where ψ: "B.in_hom ψ (F f) (F f') ∧ B.iso ψ"
using assms B.isomorphic_def by auto
obtain φ where φ: "A.in_hom φ f f' ∧ F φ = ψ"
using assms ψ is_full by blast
have "A.iso φ"
using φ ψ reflects_iso by auto
thus ?thesis
using φ A.isomorphic_def by auto
qed
end
locale embedding_functor = "functor" A B F
for A :: "'a comp"
and B :: "'b comp"
and F :: "'a ⇒ 'b" +
assumes is_embedding: "⟦ A.arr f; A.arr f'; F f = F f' ⟧ ⟹ f = f'"
sublocale embedding_functor ⊆ faithful_functor
using is_embedding by (unfold_locales, blast)
context embedding_functor
begin
lemma reflects_ide:
assumes "B.ide (F f)"
shows "A.ide f"
using assms is_embedding A.ide_in_hom B.ide_in_hom
by (metis A.in_homE B.in_homE A.ide_cod preserves_cod preserves_reflects_arr)
end
locale full_embedding_functor =
embedding_functor A B F +
full_functor A B F
for A :: "'a comp"
and B :: "'b comp"
and F :: "'a ⇒ 'b"
locale essentially_surjective_functor = "functor" +
assumes essentially_surjective: "⋀b. B.ide b ⟹ ∃a. A.ide a ∧ B.isomorphic (F a) b"
locale constant_functor =
A: category A +
B: category B
for A :: "'a comp"
and B :: "'b comp"
and b :: 'b +
assumes value_is_ide: "B.ide b"
begin
definition map
where "map f = (if A.arr f then b else B.null)"
lemma map_simp [simp]:
assumes "A.arr f"
shows "map f = b"
using assms map_def by auto
lemma is_functor:
shows "functor A B map"
using map_def value_is_ide by (unfold_locales, auto)
end
sublocale constant_functor ⊆ "functor" A B map
using is_functor by auto
locale identity_functor =
C: category C
for C :: "'a comp"
begin
definition map :: "'a ⇒ 'a"
where "map f = (if C.arr f then f else C.null)"
lemma map_simp [simp]:
assumes "C.arr f"
shows "map f = f"
using assms map_def by simp
lemma is_functor:
shows "functor C C map"
using C.arr_dom_iff_arr C.arr_cod_iff_arr
by (unfold_locales; auto simp add: map_def)
end
sublocale identity_functor ⊆ "functor" C C map
using is_functor by auto
text ‹
It is convenient to have an easy way to obtain from a category the identity functor
on that category. The following declaration causes the definitions and facts from the
@{locale identity_functor} locale to be inherited by the @{locale category} locale,
including the function @{term map} on arrows that represents the identity functor.
This makes it generally unnecessary to give explicit interpretations of
@{locale identity_functor}.
›
sublocale category ⊆ identity_functor C ..
text‹
Composition of functors coincides with function composition, thanks to the
magic of ‹null›.
›
lemma functor_comp:
assumes "functor A B F" and "functor B C G"
shows "functor A C (G o F)"
proof -
interpret F: "functor" A B F using assms(1) by auto
interpret G: "functor" B C G using assms(2) by auto
show "functor A C (G o F)"
using F.preserves_arr F.is_extensional G.is_extensional by (unfold_locales, auto)
qed
locale composite_functor =
F: "functor" A B F +
G: "functor" B C G
for A :: "'a comp"
and B :: "'b comp"
and C :: "'c comp"
and F :: "'a ⇒ 'b"
and G :: "'b ⇒ 'c"
begin
abbreviation map
where "map ≡ G o F"
end
sublocale composite_functor ⊆ "functor" A C ‹G o F›
using functor_comp F.functor_axioms G.functor_axioms by blast
lemma comp_functor_identity [simp]:
assumes "functor A B F"
shows "F o identity_functor.map A = F"
proof
interpret "functor" A B F using assms by blast
show "⋀x. (F o A.map) x = F x"
using A.map_def is_extensional by simp
qed
lemma comp_identity_functor [simp]:
assumes "functor A B F"
shows "identity_functor.map B o F = F"
proof
interpret "functor" A B F using assms by blast
show "⋀x. (B.map o F) x = F x"
using B.map_def by (metis comp_apply is_extensional preserves_arr)
qed
lemma faithful_functors_compose:
assumes "faithful_functor A B F" and "faithful_functor B C G"
shows "faithful_functor A C (G o F)"
proof -
interpret F: faithful_functor A B F
using assms(1) by simp
interpret G: faithful_functor B C G
using assms(2) by simp
interpret composite_functor A B C F G ..
show "faithful_functor A C (G o F)"
proof
show "⋀f f'. ⟦F.A.par f f'; map f = map f'⟧ ⟹ f = f'"
using F.is_faithful G.is_faithful
by (metis (mono_tags, lifting) F.preserves_arr F.preserves_cod F.preserves_dom o_apply)
qed
qed
lemma full_functors_compose:
assumes "full_functor A B F" and "full_functor B C G"
shows "full_functor A C (G o F)"
proof -
interpret F: full_functor A B F
using assms(1) by simp
interpret G: full_functor B C G
using assms(2) by simp
interpret composite_functor A B C F G ..
show "full_functor A C (G o F)"
proof
show "⋀a a' g. ⟦F.A.ide a; F.A.ide a'; «g : map a' → map a»⟧
⟹ ∃f. F.A.in_hom f a' a ∧ map f = g"
using F.is_full G.is_full
by (metis F.preserves_ide o_apply)
qed
qed
lemma fully_faithful_functors_compose:
assumes "fully_faithful_functor A B F" and "fully_faithful_functor B C G"
shows "full_functor A C (G o F)"
proof -
interpret F: fully_faithful_functor A B F
using assms(1) by simp
interpret G: fully_faithful_functor B C G
using assms(2) by simp
interpret composite_functor A B C F G ..
interpret faithful_functor A C ‹G o F›
using F.faithful_functor_axioms G.faithful_functor_axioms faithful_functors_compose
by blast
interpret full_functor A C ‹G o F›
using F.full_functor_axioms G.full_functor_axioms full_functors_compose
by blast
show "full_functor A C (G o F)" ..
qed
lemma embedding_functors_compose:
assumes "embedding_functor A B F" and "embedding_functor B C G"
shows "embedding_functor A C (G o F)"
proof -
interpret F: embedding_functor A B F
using assms(1) by simp
interpret G: embedding_functor B C G
using assms(2) by simp
interpret composite_functor A B C F G ..
show "embedding_functor A C (G o F)"
proof
show "⋀f f'. ⟦F.A.arr f; F.A.arr f'; map f = map f'⟧ ⟹ f = f'"
by (simp add: F.is_embedding G.is_embedding)
qed
qed
lemma full_embedding_functors_compose:
assumes "full_embedding_functor A B F" and "full_embedding_functor B C G"
shows "full_embedding_functor A C (G o F)"
proof -
interpret F: full_embedding_functor A B F
using assms(1) by simp
interpret G: full_embedding_functor B C G
using assms(2) by simp
interpret composite_functor A B C F G ..
interpret embedding_functor A C ‹G o F›
using F.embedding_functor_axioms G.embedding_functor_axioms embedding_functors_compose
by blast
interpret full_functor A C ‹G o F›
using F.full_functor_axioms G.full_functor_axioms full_functors_compose
by blast
show "full_embedding_functor A C (G o F)" ..
qed
lemma essentially_surjective_functors_compose:
assumes "essentially_surjective_functor A B F" and "essentially_surjective_functor B C G"
shows "essentially_surjective_functor A C (G o F)"
proof -
interpret F: essentially_surjective_functor A B F
using assms(1) by simp
interpret G: essentially_surjective_functor B C G
using assms(2) by simp
interpret composite_functor A B C F G ..
show "essentially_surjective_functor A C (G o F)"
proof
show "⋀c. G.B.ide c ⟹ ∃a. F.A.ide a ∧ G.B.isomorphic (map a) c"
proof -
fix c
assume c: "G.B.ide c"
obtain b where b: "F.B.ide b ∧ G.B.isomorphic (G b) c"
using c G.essentially_surjective by auto
obtain a where a: "F.A.ide a ∧ F.B.isomorphic (F a) b"
using b F.essentially_surjective by auto
have "G.B.isomorphic (map a) c"
proof -
have "G.B.isomorphic (G (F a)) (G b)"
using a G.preserves_iso G.B.isomorphic_def by blast
thus ?thesis
using b G.B.isomorphic_transitive by auto
qed
thus "∃a. F.A.ide a ∧ G.B.isomorphic (map a) c"
using a by auto
qed
qed
qed
locale inverse_functors =
A: category A +
B: category B +
F: "functor" B A F +
G: "functor" A B G
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and F :: "'b ⇒ 'a"
and G :: "'a ⇒ 'b" +
assumes inv: "G o F = identity_functor.map B"
and inv': "F o G = identity_functor.map A"
begin
lemma bij_betw_arr_sets:
shows "bij_betw F (Collect B.arr) (Collect A.arr)"
using inv inv'
apply (intro bij_betwI)
apply auto
using comp_eq_dest_lhs by force+
end
locale isomorphic_categories =
A: category A +
B: category B
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55) +
assumes iso: "∃F G. inverse_functors A B F G"
sublocale inverse_functors ⊆ isomorphic_categories A B
using inverse_functors_axioms by (unfold_locales, auto)
lemma inverse_functors_sym:
assumes "inverse_functors A B F G"
shows "inverse_functors B A G F"
proof -
interpret inverse_functors A B F G using assms by auto
show ?thesis using inv inv' by (unfold_locales, auto)
qed
text ‹
Inverse functors uniquely determine each other.
›
lemma inverse_functor_unique:
assumes "inverse_functors C D F G" and "inverse_functors C D F G'"
shows "G = G'"
proof -
interpret FG: inverse_functors C D F G using assms(1) by auto
interpret FG': inverse_functors C D F G' using assms(2) by auto
show "G = G'"
using FG.G.is_extensional FG'.G.is_extensional FG'.inv FG.inv'
by (metis FG'.G.functor_axioms FG.G.functor_axioms comp_assoc comp_identity_functor
comp_functor_identity)
qed
lemma inverse_functor_unique':
assumes "inverse_functors C D F G" and "inverse_functors C D F' G"
shows "F = F'"
using assms inverse_functors_sym inverse_functor_unique by blast
locale invertible_functor =
A: category A +
B: category B +
G: "functor" A B G
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and G :: "'a ⇒ 'b" +
assumes invertible: "∃F. inverse_functors A B F G"
begin
lemma has_unique_inverse:
shows "∃!F. inverse_functors A B F G"
using invertible inverse_functor_unique' by blast
definition inv
where "inv ≡ THE F. inverse_functors A B F G"
interpretation inverse_functors A B inv G
using inv_def has_unique_inverse theI' [of "λF. inverse_functors A B F G"]
by simp
lemma inv_is_inverse:
shows "inverse_functors A B inv G" ..
lemma preserves_terminal:
assumes "A.terminal a"
shows "B.terminal (G a)"
proof
show 0: "B.ide (G a)" using assms G.preserves_ide A.terminal_def by blast
fix b :: 'b
assume b: "B.ide b"
show "∃!g. «g : b →⇩B G a»"
proof
let ?F = "SOME F. inverse_functors A B F G"
from invertible have F: "inverse_functors A B ?F G"
using someI_ex [of "λF. inverse_functors A B F G"] by fast
interpret inverse_functors A B ?F G using F by auto
let ?P = "λf. «f : ?F b →⇩A a»"
have 1: "∃!f. ?P f" using assms b A.terminal_def by simp
hence 2: "?P (THE f. ?P f)" by (metis (no_types, lifting) theI')
thus "«G (THE f. ?P f) : b →⇩B G a»"
using b apply (elim A.in_homE, intro B.in_homI, auto)
using B.ideD(1) B.map_simp comp_def inv by metis
hence 3: "«(THE f. ?P f) : ?F b →⇩A a»"
using assms 2 b F by simp
fix g :: 'b
assume g: "«g : b →⇩B G a»"
have "?F (G a) = a"
using assms(1) A.terminal_def inv' A.map_simp
by (metis 0 B.ideD(1) G.preserves_reflects_arr comp_eq_dest_lhs)
hence "«?F g : ?F b →⇩A a»"
using assms(1) g A.terminal_def inv
by (elim B.in_homE, auto)
hence "?F g = (THE f. ?P f)" using assms 1 3 A.terminal_def by blast
thus "g = G (THE f. ?P f)"
using inv g by (metis B.in_homE B.map_simp comp_def)
qed
qed
end
sublocale invertible_functor ⊆ inverse_functors A B inv G
using inv_is_inverse by simp
text ‹
A bijection from a set ‹S› to the set of arrows of a category ‹C› induces an isomorphic
copy of ‹C› having ‹S› as its set of arrows, assuming that there exists some ‹n ∉ S›
to serve as the null.
›
context category
begin
lemma bij_induces_invertible_functor:
assumes "bij_betw φ S (Collect arr)" and "n ∉ S"
shows "∃C'. Collect (partial_magma.arr C') = S ∧
invertible_functor C' C (λi. if partial_magma.arr C' i then φ i else null)"
proof -
define ψ where "ψ = (λf. if arr f then inv_into S φ f else n)"
have ψ: "bij_betw ψ (Collect arr) S"
using assms(1) ψ_def bij_betw_inv_into
by (metis (no_types, lifting) bij_betw_cong mem_Collect_eq)
have φ_ψ [simp]: "⋀f. arr f ⟹ φ (ψ f) = f"
using assms(1) ψ ψ_def bij_betw_inv_into_right by fastforce
have ψ_φ [simp]: "⋀i. i ∈ S ⟹ ψ (φ i) = i"
unfolding ψ_def
using assms(1) ψ bij_betw_inv_into_left [of φ S "Collect arr"]
by (metis bij_betw_def image_eqI mem_Collect_eq)
define C' where "C' = (λi j. if i ∈ S ∧ j ∈ S ∧ seq (φ i) (φ j) then ψ (φ i ⋅ φ j) else n)"
interpret C': partial_magma C'
using assms(1-2) C'_def ψ_def
by unfold_locales metis
have null_char: "C'.null = n"
using assms(1-2) C'_def ψ_def C'.null_eqI by metis
have ide_char: "⋀i. C'.ide i ⟷ i ∈ S ∧ ide (φ i)"
proof
fix i
assume i: "C'.ide i"
show "i ∈ S ∧ ide (φ i)"
proof (unfold ide_def, intro conjI)
show 1: "φ i ⋅ φ i ≠ null"
using i assms(1) C'.ide_def C'_def null_char by auto
show 2: "i ∈ S"
using 1 assms(1) by (metis C'.ide_def C'_def i)
show "∀f. (f ⋅ φ i ≠ null ⟶ f ⋅ φ i = f) ∧ (φ i ⋅ f ≠ null ⟶ φ i ⋅ f = f)"
proof (intro allI conjI impI)
show "⋀f. f ⋅ φ i ≠ null ⟹ f ⋅ φ i = f"
proof -
fix f
assume f: "f ⋅ φ i ≠ null"
hence 1: "arr f ∧ arr (φ i) ∧ seq f (φ i)"
by (meson seqE ext)
have "f ⋅ φ i = φ (C' (ψ f) i)"
using 1 2 C'_def null_char
by (metis (no_types, lifting) φ_ψ ψ bij_betw_def image_eqI mem_Collect_eq)
also have "... = f"
by (metis 1 C'.ide_def C'_def φ_ψ ψ assms(2) bij_betw_def i image_eqI
mem_Collect_eq null_char)
finally show "f ⋅ φ i = f" by simp
qed
show "⋀f. φ i ⋅ f ≠ null ⟹ φ i ⋅ f = f"
proof -
fix f
assume f: "φ i ⋅ f ≠ null"
hence 1: "arr f ∧ arr (φ i) ∧ seq (φ i) f"
by (meson seqE ext)
show "φ i ⋅ f = f"
using 1 2 C'_def null_char ψ
by (metis (no_types, lifting) ‹⋀f. f ⋅ φ i ≠ null ⟹ f ⋅ φ i = f›
ide_char' codomains_null comp_cod_arr has_codomain_iff_arr
comp_ide_arr)
qed
qed
qed
next
fix i
assume i: "i ∈ S ∧ ide (φ i)"
have "ψ (φ i) ∈ S"
using i assms(1)
by (metis ψ bij_betw_def ideD(1) image_eqI mem_Collect_eq)
show "C'.ide i"
using assms(2) i C'_def null_char comp_arr_ide comp_ide_arr
apply (unfold C'.ide_def, intro conjI allI impI)
apply auto[1]
by force+
qed
have dom: "⋀i. i ∈ S ⟹ ψ (dom (φ i)) ∈ C'.domains i"
proof -
fix i
assume i: "i ∈ S"
have 1: "C'.ide (ψ (dom (φ i)))"
proof (unfold C'.ide_def, intro conjI allI impI)
show "C' (ψ (dom (φ i))) (ψ (dom (φ i))) ≠ C'.null"
proof -
have "C' (ψ (dom (φ i))) (ψ (dom (φ i))) = ψ (dom (φ i))"
using C'_def i assms(1-2) ψ ψ_φ ψ_def bij_betw_def
by (metis (no_types, lifting) C'.ide_def φ_ψ ide_char ide_dom image_eqI
mem_Collect_eq)
moreover have "ψ (dom (φ i)) ≠ C'.null"
using i null_char assms(1-2) bij_betw_def
by (metis ψ arr_dom_iff_arr image_iff mem_Collect_eq)
ultimately show ?thesis
by simp
qed
show "⋀j. C' j (ψ (dom (φ i))) ≠ C'.null ⟹ C' j (ψ (dom (φ i))) = j"
proof -
fix j
assume j: "C' j (ψ (dom (φ i))) ≠ C'.null"
show "C' j (ψ (dom (φ i))) = j"
using j φ_ψ ψ_def ide_char null_char
by (metis C'.comp_null(2) C'.ide_def C'_def
‹C' (ψ (dom (φ i))) (ψ (dom (φ i))) ≠ C'.null›
arr_dom_iff_arr ide_dom)
qed
show "⋀j. C' (ψ (dom (φ i))) j ≠ C'.null ⟹ C' (ψ (dom (φ i))) j = j"
proof -
fix j
assume j: "C' (ψ (dom (φ i))) j ≠ C'.null"
show "C' (ψ (dom (φ i))) j = j"
using j
by (metis C'.ide_def C'_def
‹C' (ψ (dom (φ i))) (ψ (dom (φ i))) ≠ C'.null›
‹⋀j. C' j (ψ (dom (φ i))) ≠ C'.null ⟹ C' j (ψ (dom (φ i))) = j›
φ_ψ ψ_def arr_dom_iff_arr ide_char ide_dom null_char)
qed
qed
moreover have "C' i (ψ (dom (φ i))) ≠ C'.null"
using i 1 assms(1-2) C'_def null_char ide_char φ_ψ ψ_φ ψ_def comp_arr_dom
apply simp
by (metis (no_types, lifting))
ultimately show "ψ (dom (φ i)) ∈ C'.domains i"
using C'.domains_def by simp
qed
have cod: "⋀i. i ∈ S ⟹ ψ (cod (φ i)) ∈ C'.codomains i"
proof -
fix i
assume i: "i ∈ S"
have 1: "C'.ide (ψ (cod (φ i)))"
proof (unfold C'.ide_def, intro conjI allI impI)
show "C' (ψ (cod (φ i))) (ψ (cod (φ i))) ≠ C'.null"
proof -
have "C' (ψ (cod (φ i))) (ψ (cod (φ i))) = ψ (cod (φ i))"
proof -
have "φ (ψ (cod (φ i))) = cod (φ i)"
using i assms(1-2) φ_ψ ψ_φ ψ_def arr_cod_iff_arr by force
moreover have "cod (φ i) ⋅ cod (φ i) = cod (φ i)"
using i assms(1-2) comp_ide_self ide_cod [of "φ i"] ψ_φ ψ_def by fastforce
ultimately show ?thesis
using C'_def i assms(1)
apply simp
by (metis (no_types, lifting) ψ ψ_def bij_betw_def image_eqI mem_Collect_eq)
qed
moreover have "ψ (cod (φ i)) ≠ C'.null"
using i null_char assms(1-2)
by (metis ψ bij_betw_def category.arr_cod_iff_arr category_axioms
image_eqI mem_Collect_eq)
ultimately show ?thesis
by simp
qed
show "⋀j. C' (ψ (cod (φ i))) j ≠ C'.null ⟹ C' (ψ (cod (φ i))) j = j"
proof -
fix j
assume j: "C' (ψ (cod (φ i))) j ≠ C'.null"
show "C' (ψ (cod (φ i))) j = j"
using j
by (metis C'.comp_null(2) C'.ide_def C'_def
‹C' (ψ (cod (φ i))) (ψ (cod (φ i))) ≠ C'.null›
φ_ψ ψ_def arr_cod_iff_arr category.ide_cod category_axioms ide_char null_char)
qed
show "⋀j. C' j (ψ (cod (φ i))) ≠ C'.null ⟹ C' j (ψ (cod (φ i))) = j"
proof -
fix j
assume j: "C' j (ψ (cod (φ i))) ≠ C'.null"
show "C' j (ψ (cod (φ i))) = j"
using j
by (metis C'.ide_def C'_def ‹C' (ψ (cod (φ i))) (ψ (cod (φ i))) ≠ C'.null›
‹⋀j. C' (ψ (cod (φ i))) j ≠ C'.null ⟹ C' (ψ (cod (φ i))) j = j›
φ_ψ ψ_def arr_cod_iff_arr category.ide_cod category_axioms ide_char null_char)
qed
qed
moreover have "C' (ψ (cod (φ i))) i ≠ C'.null"
using i assms(1-2) C'_def null_char φ_ψ ψ_φ ψ_def comp_cod_arr ide_char
apply simp
by (metis (no_types, lifting) ψ_def 1)
ultimately show "ψ (cod (φ i)) ∈ C'.codomains i"
using C'.codomains_def by simp
qed
have arr_char: "⋀i. C'.arr i ⟷ i ∈ S"
proof
fix i
show "i ∈ S ⟹ C'.arr i"
using dom cod C'.arr_def by auto
show "C'.arr i ⟹ i ∈ S"
using C'_def C'.arr_def C'.domains_def C'.codomains_def null_char
apply simp
by metis
qed
have seq_char: "⋀i j. C'.seq i j ⟷ i ∈ S ∧ j ∈ S ∧ seq (φ i) (φ j)"
using assms(1-2) C'_def arr_char null_char
apply simp
using ψ bij_betw_apply by fastforce
interpret C': category C'
proof
show "⋀g f. C' g f ≠ C'.null ⟹ C'.seq g f"
using C'_def null_char seq_char by fastforce
show "⋀f. (C'.domains f ≠ {}) = (C'.codomains f ≠ {})"
using dom cod null_char arr_char C'.arr_def by blast
show "⋀h g f. ⟦C'.seq h g; C'.seq (C' h g) f⟧ ⟹ C'.seq g f"
using seq_char
apply simp
using C'_def by fastforce
show "⋀h g f. ⟦C'.seq h (C' g f); C'.seq g f⟧ ⟹ C'.seq h g"
using seq_char
apply simp
using C'_def by fastforce
show "⋀g f h. ⟦C'.seq g f; C'.seq h g⟧ ⟹ C'.seq (C' h g) f"
using seq_char arr_char
apply simp
using C'_def by auto
show "⋀g f h. ⟦C'.seq g f; C'.seq h g⟧ ⟹ C' (C' h g) f = C' h (C' g f)"
using seq_char arr_char C'_def comp_assoc assms(2)
apply simp by presburger
qed
have dom_char: "C'.dom = (λi. if i ∈ S then ψ (dom (φ i)) else n)"
using dom arr_char null_char C'.dom_eqI' C'.arr_def C'.dom_def by metis
have cod_char: "C'.cod = (λi. if i ∈ S then ψ (cod (φ i)) else n)"
using cod arr_char null_char C'.cod_eqI' C'.arr_def C'.cod_def by metis
interpret φ: "functor" C' C ‹λi. if C'.arr i then φ i else null›
using arr_char null_char dom_char cod_char seq_char φ_ψ ψ_φ ψ_def C'.not_arr_null C'_def
C'.arr_dom C'.arr_cod
apply unfold_locales
apply simp_all
apply (metis (full_types))
apply force
apply force
by metis
interpret ψ: "functor" C C' ψ
using ψ_def null_char arr_char
apply unfold_locales
apply simp
apply (metis (no_types, lifting) ψ bij_betw_def image_eqI mem_Collect_eq)
apply (metis (no_types, lifting) φ_ψ ψ bij_betw_def dom_char image_eqI mem_Collect_eq)
apply (metis (no_types, lifting) φ_ψ ψ bij_betw_def cod_char image_eqI mem_Collect_eq)
by (metis (no_types, lifting) C'_def φ_ψ ψ bij_betw_def seqE image_eqI mem_Collect_eq)
interpret φψ: inverse_functors C' C ψ ‹λi. if C'.arr i then φ i else null›
proof
show "ψ ∘ (λi. if C'.arr i then φ i else null) = C'.map"
by (auto simp add: C'.is_extensional ψ.is_extensional arr_char)
show "(λi. if C'.arr i then φ i else null) ∘ ψ = map"
by (auto simp add: is_extensional)
qed
have "invertible_functor C' C (λi. if C'.arr i then φ i else null)"
using φψ.inverse_functors_axioms by unfold_locales auto
thus ?thesis
using arr_char by blast
qed
corollary (in category) finite_imp_ex_iso_nat_comp:
assumes "finite (Collect arr)"
shows "∃C' :: nat comp. isomorphic_categories C' C"
proof -
obtain n :: nat and φ where φ: "bij_betw φ {0..<n} (Collect arr)"
using assms ex_bij_betw_nat_finite by blast
obtain C' where C': "Collect (partial_magma.arr C') = {0..<n} ∧
invertible_functor C' (⋅)
(λi. if partial_magma.arr C' i then φ i else null)"
using φ bij_induces_invertible_functor [of φ "{0..<n}"] by auto
interpret φ: invertible_functor C' C ‹λi. if partial_magma.arr C' i then φ i else null›
using C' by simp
show ?thesis
using φ.isomorphic_categories_axioms by blast
qed
end
text ‹
We now prove the result, advertised earlier in theory ‹ConcreteCategory›,
that any category is in fact isomorphic to the concrete category formed from it in
the obvious way.
›
context category
begin
interpretation CC: concrete_category ‹Collect ide› hom id ‹λC B A g f. g ⋅ f›
using comp_arr_dom comp_cod_arr comp_assoc
by (unfold_locales, auto)
interpretation F: "functor" C CC.COMP
‹λf. if arr f then CC.MkArr (dom f) (cod f) f else CC.null›
by (unfold_locales, auto simp add: in_homI)
interpretation G: "functor" CC.COMP C ‹λF. if CC.arr F then CC.Map F else null›
using CC.Map_in_Hom CC.seq_char
by (unfold_locales, auto)
interpretation FG: inverse_functors C CC.COMP
‹λF. if CC.arr F then CC.Map F else null›
‹λf. if arr f then CC.MkArr (dom f) (cod f) f else CC.null›
proof
show "(λF. if CC.arr F then CC.Map F else null) ∘
(λf. if arr f then CC.MkArr (dom f) (cod f) f else CC.null) =
map"
using CC.arr_char map_def by fastforce
show "(λf. if arr f then CC.MkArr (dom f) (cod f) f else CC.null) ∘
(λF. if CC.arr F then CC.Map F else null) =
CC.map"
using CC.MkArr_Map G.preserves_arr G.preserves_cod G.preserves_dom
CC.is_extensional
by auto
qed
interpretation isomorphic_categories C CC.COMP ..
theorem is_isomorphic_to_concrete_category:
shows "isomorphic_categories C CC.COMP"
..
end
locale dual_functor =
F: "functor" A B F +
Aop: dual_category A +
Bop: dual_category B
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and F :: "'a ⇒ 'b"
begin
notation Aop.comp (infixr "⋅⇩A⇧o⇧p" 55)
notation Bop.comp (infixr "⋅⇩B⇧o⇧p" 55)
definition map
where "map ≡ F"
lemma map_simp [simp]:
shows "map f = F f"
by (simp add: map_def)
lemma is_functor:
shows "functor Aop.comp Bop.comp map"
using F.is_extensional by (unfold_locales, auto)
end
sublocale invertible_functor ⊆ inverse_functors A B inv G
using inv_is_inverse by simp
sublocale dual_functor ⊆ "functor" Aop.comp Bop.comp map
using is_functor by auto
end
Theory SetCategory
chapter SetCategory
theory SetCategory
imports Category Functor "HOL-Cardinals.Cardinals"
begin
text‹
This theory defines a locale ‹set_category› that axiomatizes the notion
``category of @{typ 'a}-sets and functions between them'' in the context of HOL.
A primary reason for doing this is to make it possible to prove results
(such as the Yoneda Lemma) that use such categories without having to commit to a
particular element type @{typ 'a} and without having the results depend on the
concrete details of a particular construction.
The axiomatization given here is categorical, in the sense that if categories
@{term S} and @{term S'} each interpret the ‹set_category› locale,
then a bijection between the sets of terminal objects of @{term S} and @{term S'}
extends to an isomorphism of @{term S} and @{term S'} as categories.
The axiomatization is based on the following idea: if, for some type @{typ 'a},
category @{term S} is the category of all @{typ 'a}-sets and functions between
them, then the elements of type @{typ 'a} are in bijective correspondence with
the terminal objects of category @{term S}. In addition, if @{term unity}
is an arbitrarily chosen terminal object of @{term S}, then for each object @{term a},
the hom-set @{term "hom unity a"} (\emph{i.e.} the set of ``points'' or
``global elements'' of @{term a}) is in bijective correspondence with a subset
of the terminal objects of @{term S}. By making a specific, but arbitrary,
choice of such a correspondence, we can then associate with each object @{term a}
of @{term S} a set @{term "set a"} that consists of all terminal objects @{term t}
that correspond to some point @{term x} of @{term a}. Each arrow @{term f}
then induces a function ‹Fun f ∈ set (dom f) → set (cod f)›,
defined on terminal objects of @{term S} by passing to points of @{term "dom f"},
composing with @{term f}, then passing back from points of @{term "cod f"}
to terminal objects. Once we can associate a set with each object of @{term S}
and a function with each arrow, we can force @{term S} to be isomorphic to the
category of @{typ 'a}-sets by imposing suitable extensionality and completeness axioms.
›
section "Some Lemmas about Restriction"
text‹
\sloppypar
The development of the ‹set_category› locale makes heavy use of the
theory @{theory "HOL-Library.FuncSet"}. However, in some cases, I found that
that theory did not provide results about restriction in the form that was
most useful to me. I used the following additional results in various places.
›
lemma restr_eqI:
assumes "A = A'" and "⋀x. x ∈ A ⟹ F x = F' x"
shows "restrict F A = restrict F' A'"
using assms by force
lemma restr_eqE [elim]:
assumes "restrict F A = restrict F' A" and "x ∈ A"
shows "F x = F' x"
using assms restrict_def by metis
lemma compose_eq' [simp]:
shows "compose A G F = restrict (G o F) A"
unfolding compose_def restrict_def by auto
section "Set Categories"
text‹
We first define the locale ‹set_category_data›, which sets out the basic
data and definitions for the ‹set_category› locale, without imposing any conditions
other than that @{term S} is a category and that @{term img} is a function defined
on the arrow type of @{term S}. The function @{term img} should be thought of
as a mapping that takes a point @{term "x ∈ hom unity a"} to a corresponding
terminal object @{term "img x"}. Eventually, assumptions will be introduced so
that this is in fact the case.
›
locale set_category_data = category S
for S :: "'s comp" (infixr "⋅" 55)
and img :: "'s ⇒ 's"
begin
notation in_hom ("«_ : _ → _»")
text‹
Call the set of all terminal objects of S the ``universe''.
›
abbreviation Univ :: "'s set"
where "Univ ≡ Collect terminal"
text‹
Choose an arbitrary element of the universe and call it @{term unity}.
›
definition unity :: 's
where "unity = (SOME t. terminal t)"
text‹
Each object @{term a} determines a subset @{term "set a"} of the universe,
consisting of all those terminal objects @{term t} such that @{term "t = img x"}
for some @{term "x ∈ hom unity a"}.
›
definition set :: "'s ⇒ 's set"
where "set a = img ` hom unity a"
end
text‹
Next, we define a locale ‹set_category_given_img› that augments the
‹set_category_data› locale with assumptions that serve to define
the notion of a set category with a chosen correspondence between points
and terminal objects. The assumptions require that the universe be nonempty
(so that the definition of @{term unity} makes sense), that the map
@{term img} is a locally injective map taking points to terminal objects,
that each terminal object @{term t} belongs to @{term "set t"},
that two objects of @{term S} are equal if they determine the same set,
that two parallel arrows of @{term S} are equal if they determine the same
function, that there is an object corresponding to each subset of the universe
whose cardinality is less than a specified cardinal ‹𝔄›, and that for any objects
@{term a} and @{term b} and function @{term "F ∈ hom unity a → hom unity b"}
there is an arrow @{term "f ∈ hom a b"} whose action under the composition
of @{term S} coincides with the function @{term F}.
The cardinal ‹𝔄›, which is given as a parameter to the locale, has been introduced
because most of the familiar properties of a set category do not depend on
there being an object corresponding to \emph{every} subset of the universe,
and we would like to consider such situations; for example, the situation in
which there only \emph{finite} subsets determine objects.
›
locale set_category_given_img = set_category_data S img
for S :: "'s comp" (infixr "⋅" 55)
and img :: "'s ⇒ 's"
and 𝔄 :: "'t rel" +
assumes nonempty_Univ: "Univ ≠ {}"
and img_mapsto: "ide a ⟹ img ∈ hom unity a → Univ"
and card_points: "ide a ⟹ |hom unity a| <o 𝔄"
and inj_img: "ide a ⟹ inj_on img (hom unity a)"
and stable_img: "terminal t ⟹ t ∈ img ` hom unity t"
and extensional_set: "⟦ ide a; ide b; set a = set b ⟧ ⟹ a = b"
and extensional_arr: "⟦ par f f'; ⋀x. «x : unity → dom f» ⟹ f ⋅ x = f' ⋅ x ⟧ ⟹ f = f'"
and set_complete: "⟦ A ⊆ Univ; |A| <o 𝔄 ⟧ ⟹ ∃a. ide a ∧ set a = A"
and fun_complete1: "⟦ ide a; ide b; F ∈ hom unity a → hom unity b ⟧
⟹ ∃f. «f : a → b» ∧ (∀x. «x : unity → dom f» ⟶ f ⋅ x = F x)"
and cardinal: "Card_order 𝔄 ∧ infinite (Field 𝔄)"
begin
text‹
The inverse of the map @{term set} is a map @{term mkIde} that takes each subset
of the universe of cardinality less than ‹𝔄› to an identity of @{term[source=true] S}.
›
definition mkIde :: "'s set ⇒ 's"
where "mkIde A = (if A ⊆ Univ ∧ |A| <o 𝔄 then inv_into (Collect ide) set A else null)"
text‹
Each arrow @{term "f ∈ hom a b"} determines a function @{term "Fun f ∈ Univ → Univ"},
by passing from @{term Univ} to @{term "hom a unity"}, composing with @{term f},
then passing back to @{term Univ}.
›
definition Fun :: "'s ⇒ 's ⇒ 's"
where "Fun f = restrict (img o S f o inv_into (hom unity (dom f)) img) (set (dom f))"
lemma comp_arr_point:
assumes "arr f" and "«x : unity → dom f»"
shows "f ⋅ x = inv_into (hom unity (cod f)) img (Fun f (img x))"
proof -
have "«f ⋅ x : unity → cod f»"
using assms by blast
thus ?thesis
using assms Fun_def inj_img set_def by simp
qed
text‹
Parallel arrows that determine the same function are equal.
›
lemma arr_eqI:
assumes "par f f'" and "Fun f = Fun f'"
shows "f = f'"
using assms comp_arr_point extensional_arr by metis
lemma terminal_unity:
shows "terminal unity"
using unity_def nonempty_Univ by (simp add: someI_ex)
lemma ide_unity [simp]:
shows "ide unity"
using terminal_unity terminal_def by blast
lemma set_subset_Univ [simp]:
assumes "ide a"
shows "set a ⊆ Univ"
using assms set_def img_mapsto by auto
lemma inj_on_set:
shows "inj_on set (Collect ide)"
using extensional_set by (intro inj_onI, auto)
text‹
The mapping @{term mkIde}, which takes subsets of the universe to identities,
and @{term set}, which takes identities to subsets of the universe, are inverses.
›
lemma set_card:
assumes "ide a"
shows "|set a| <o 𝔄"
using assms card_points set_def
by (metis card_of_image ordLeq_ordLess_trans)
lemma mkIde_set [simp]:
assumes "ide a"
shows "mkIde (set a) = a"
using assms mkIde_def inj_on_set inv_into_f_f set_card
by (simp add: ordLess_imp_ordLeq)
lemma set_mkIde:
assumes "A ⊆ Univ" and "|A| <o 𝔄"
shows "set (mkIde A) = A"
using assms mkIde_def set_complete someI_ex [of "λa. a ∈ Collect ide ∧ set a = A"]
by (metis set_category_given_img.mkIde_set set_category_given_img_axioms)
lemma ide_mkIde:
assumes "A ⊆ Univ" and "|A| <o 𝔄"
shows "ide (mkIde A)"
using assms mkIde_def mkIde_set set_complete by metis
text‹
Because we have assumed the cardinal ‹𝔄› to be infinite, there is an object corresponding
to every finite subset of the universe.
›
lemma ide_mkIde_finite:
assumes "A ⊆ Univ" and "finite A"
shows "ide (mkIde A)"
proof -
have "|A| <o 𝔄"
proof -
have "finite (Field |A| )"
using assms(2) by simp
thus ?thesis
using cardinal card_of_Well_order card_order_on_def finite_ordLess_infinite
by blast
qed
thus ?thesis
using assms(1) ide_mkIde [of A] by simp
qed
lemma arr_mkIde:
shows "arr (mkIde A) ⟷ A ⊆ Univ ∧ |A| <o 𝔄"
using ide_mkIde mkIde_def not_arr_null by force
lemma dom_mkIde:
assumes "A ⊆ Univ" and "|A| <o 𝔄"
shows "dom (mkIde A) = mkIde A"
using assms ide_mkIde by simp
lemma cod_mkIde:
assumes "A ⊆ Univ" and "|A| <o 𝔄"
shows "cod (mkIde A) = mkIde A"
using assms ide_mkIde by simp
text‹
Each arrow @{term f} determines an extensional function from
@{term "set (dom f)"} to @{term "set (cod f)"}.
›
lemma Fun_mapsto:
assumes "arr f"
shows "Fun f ∈ extensional (set (dom f)) ∩ (set (dom f) → set (cod f))"
proof
show "Fun f ∈ extensional (set (dom f))" using Fun_def by fastforce
show "Fun f ∈ set (dom f) → set (cod f)"
proof
fix t
assume t: "t ∈ set (dom f)"
have "Fun f t = img (f ⋅ inv_into (hom unity (dom f)) img t)"
using assms t Fun_def comp_def by simp
moreover have "... ∈ set (cod f)"
using assms t set_def inv_into_into [of t img "hom unity (dom f)"] by blast
ultimately show "Fun f t ∈ set (cod f)" by auto
qed
qed
text‹
Identities of @{term[source=true] S} correspond to restrictions of the identity function.
›
lemma Fun_ide:
assumes "ide a"
shows "Fun a = restrict (λx. x) (set a)"
using assms Fun_def inj_img set_def comp_cod_arr by fastforce
lemma Fun_mkIde:
assumes "A ⊆ Univ" and "|A| <o 𝔄"
shows "Fun (mkIde A) = restrict (λx. x) A"
using assms ide_mkIde set_mkIde Fun_ide by simp
text‹
Composition in @{term S} corresponds to extensional function composition.
›
lemma Fun_comp [simp]:
assumes "seq g f"
shows "Fun (g ⋅ f) = restrict (Fun g o Fun f) (set (dom f))"
proof -
have "restrict (img o S (g ⋅ f) o (inv_into (hom unity (dom (g ⋅ f))) img))
(set (dom (g ⋅ f)))
= restrict (Fun g o Fun f) (set (dom f))"
proof -
have 1: "set (dom (g ⋅ f)) = set (dom f)"
using assms by auto
let ?img' = "λa. λt. inv_into (hom unity a) img t"
have 2: "⋀t. t ∈ set (dom (g ⋅ f)) ⟹
(img o S (g ⋅ f) o ?img' (dom (g ⋅ f))) t = (Fun g o Fun f) t"
proof -
fix t
assume "t ∈ set (dom (g ⋅ f))"
hence t: "t ∈ set (dom f)" by (simp add: 1)
have 3: "⋀a x. x ∈ hom unity a ⟹ ?img' a (img x) = x"
using assms inj_img ide_cod inv_into_f_eq
by (metis arrI in_homE mem_Collect_eq)
have 4: "?img' (dom f) t ∈ hom unity (dom f)"
using assms t inv_into_into [of t img "hom unity (dom f)"] set_def by simp
have "(img o S (g ⋅ f) o ?img' (dom (g ⋅ f))) t = img (g ⋅ f ⋅ ?img' (dom f) t)"
using assms dom_comp comp_assoc by simp
also have "... = img (g ⋅ ?img' (dom g) (Fun f t))"
using assms t 3 Fun_def set_def comp_arr_point by auto
also have "... = Fun g (Fun f t)"
proof -
have "Fun f t ∈ img ` hom unity (cod f)"
using assms t Fun_mapsto set_def by fast
thus ?thesis using assms by (auto simp add: set_def Fun_def)
qed
finally show "(img o S (g ⋅ f) o ?img' (dom (g ⋅ f))) t = (Fun g o Fun f) t"
by auto
qed
show ?thesis using 1 2 by auto
qed
thus ?thesis using Fun_def by auto
qed
text‹
The constructor @{term mkArr} is used to obtain an arrow given subsets
@{term A} and @{term B} of the universe and a function @{term "F ∈ A → B"}.
›
definition mkArr :: "'s set ⇒ 's set ⇒ ('s ⇒ 's) ⇒ 's"
where "mkArr A B F = (if A ⊆ Univ ∧ |A| <o 𝔄 ∧ B ⊆ Univ ∧ |B| <o 𝔄 ∧ F ∈ A → B
then (THE f. f ∈ hom (mkIde A) (mkIde B) ∧ Fun f = restrict F A)
else null)"
text‹
Each function @{term "F ∈ set a → set b"} determines a unique arrow @{term "f ∈ hom a b"},
such that @{term "Fun f"} is the restriction of @{term F} to @{term "set a"}.
›
lemma fun_complete:
assumes "ide a" and "ide b" and "F ∈ set a → set b"
shows "∃!f. «f : a → b» ∧ Fun f = restrict F (set a)"
proof -
let ?P = "λf. «f : a → b» ∧ Fun f = restrict F (set a)"
show "∃!f. ?P f"
proof
have "∃f. ?P f"
proof -
let ?F' = "λx. inv_into (hom unity b) img (F (img x))"
have "?F' ∈ hom unity a → hom unity b"
proof
fix x
assume x: "x ∈ hom unity a"
have "F (img x) ∈ set b" using assms(3) x set_def by auto
thus "inv_into (hom unity b) img (F (img x)) ∈ hom unity b"
using assms inj_img set_def by auto
qed
hence "∃f. «f : a → b» ∧ (∀x. «x : unity → a» ⟶ f ⋅ x = ?F' x)"
using assms fun_complete1 [of a b] by force
from this obtain f where f: "«f : a → b» ∧ (∀x. «x : unity → a» ⟶ f ⋅ x = ?F' x)"
by blast
let ?img' = "λa. λt. inv_into (hom unity a) img t"
have "Fun f = restrict F (set a)"
proof (unfold Fun_def, intro restr_eqI)
show "set (dom f) = set a" using f by auto
show "⋀t. t ∈ set (dom f) ⟹ (img ∘ S f ∘ ?img' (dom f)) t = F t"
proof -
fix t
assume t: "t ∈ set (dom f)"
have "(img ∘ S f ∘ ?img' (dom f)) t = img (f ⋅ ?img' (dom f) t)"
by simp
also have "... = img (?F' (?img' (dom f) t))"
proof -
have "?img' (dom f) t ∈ hom unity (dom f)"
using t set_def inv_into_into by metis
thus ?thesis using f by auto
qed
also have "... = img (?img' (cod f) (F t))"
using f t set_def inj_img by auto
also have "... = F t"
proof -
have "F t ∈ set (cod f)"
using assms f t by auto
thus ?thesis
using f t set_def inj_img by auto
qed
finally show "(img ∘ S f ∘ ?img' (dom f)) t = F t" by auto
qed
qed
thus ?thesis using f by blast
qed
thus F: "?P (SOME f. ?P f)" using someI_ex [of ?P] by fast
show "⋀f'. ?P f' ⟹ f' = (SOME f. ?P f)"
using F arr_eqI
by (metis (no_types, lifting) in_homE)
qed
qed
lemma mkArr_in_hom:
assumes "A ⊆ Univ" and "|A| <o 𝔄" and "B ⊆ Univ" and "|B| <o 𝔄" and "F ∈ A → B"
shows "«mkArr A B F : mkIde A → mkIde B»"
using assms mkArr_def fun_complete [of "mkIde A" "mkIde B" F] ide_mkIde set_mkIde
theI' [of "λf. f ∈ hom (mkIde A) (mkIde B) ∧ Fun f = restrict F A"]
by simp
text‹
The ``only if'' direction of the next lemma can be achieved only if there exists a
non-arrow element of type @{typ 's}, which can be used as the value of @{term "mkArr A B F"}
in cases where @{term "F ∉ A → B"}. Nevertheless, it is essential to have this,
because without the ``only if'' direction, we can't derive any useful
consequences from an assumption of the form @{term "arr (mkArr A B F)"};
instead we have to obtain @{term "F ∈ A → B"} some other way.
This is is usually highly inconvenient and it makes the theory very weak and almost
unusable in practice. The observation that having a non-arrow value of type @{typ 's}
solves this problem is ultimately what led me to incorporate @{term null} first into the
definition of the ‹set_category› locale and then, ultimately, into the definition
of the ‹category› locale. I believe this idea is critical to the usability of the
entire development.
›
lemma arr_mkArr:
shows "arr (mkArr A B F) ⟷
A ⊆ Univ ∧ |A| <o 𝔄 ∧ B ⊆ Univ ∧ |B| <o 𝔄 ∧ F ∈ A → B"
proof
show "arr (mkArr A B F) ⟹
A ⊆ Univ ∧ |A| <o 𝔄 ∧ B ⊆ Univ ∧ |B| <o 𝔄 ∧ F ∈ A → B"
using mkArr_def domains_null codomains_null has_domain_iff_arr has_codomain_iff_arr
not_arr_null
by (intro conjI) metis+
show "A ⊆ Univ ∧ |A| <o 𝔄 ∧ B ⊆ Univ ∧ |B| <o 𝔄 ∧ F ∈ A → B
⟹ arr (mkArr A B F)"
using mkArr_in_hom by auto
qed
lemma Fun_mkArr':
assumes "arr (mkArr A B F)"
shows "«mkArr A B F : mkIde A → mkIde B»"
and "Fun (mkArr A B F) = restrict F A"
proof -
have 1: "A ⊆ Univ ∧ |A| <o 𝔄 ∧ B ⊆ Univ ∧ |B| <o 𝔄 ∧ F ∈ A → B"
using assms arr_mkArr by simp
have 2: "mkArr A B F ∈ hom (mkIde A) (mkIde B) ∧
Fun (mkArr A B F) = restrict F (set (mkIde A))"
proof -
have "∃!f. f ∈ hom (mkIde A) (mkIde B) ∧ Fun f = restrict F (set (mkIde A))"
using 1 fun_complete [of "mkIde A" "mkIde B" F] ide_mkIde set_mkIde by simp
thus ?thesis using 1 mkArr_def theI' set_mkIde by simp
qed
show "«mkArr A B F : mkIde A → mkIde B»" using 1 2 by auto
show "Fun (mkArr A B F) = restrict F A" using 1 2 set_mkIde by auto
qed
lemma mkArr_Fun:
assumes "arr f"
shows "mkArr (set (dom f)) (set (cod f)) (Fun f) = f"
proof -
have 1: "set (dom f) ⊆ Univ ∧ |set (dom f)| <o 𝔄 ∧
set (cod f) ⊆ Univ ∧ |set (cod f)| <o 𝔄 ∧
ide (dom f) ∧ ide (cod f) ∧
Fun f ∈ extensional (set (dom f)) ∩ (set (dom f) → set (cod f))"
using assms Fun_mapsto set_def set_card set_subset_Univ by auto
hence "∃!f'. f' ∈ hom (dom f) (cod f) ∧ Fun f' = restrict (Fun f) (set (dom f))"
using fun_complete by force
moreover have "f ∈ hom (dom f) (cod f) ∧ Fun f = restrict (Fun f) (set (dom f))"
using assms 1 extensional_restrict by force
ultimately have "f = (THE f'. f' ∈ hom (dom f) (cod f) ∧
Fun f' = restrict (Fun f) (set (dom f)))"
using theI' [of "λf'. f' ∈ hom (dom f) (cod f) ∧ Fun f' = restrict (Fun f) (set (dom f))"]
by blast
also have "... = mkArr (set (dom f)) (set (cod f)) (Fun f)"
using assms 1 mkArr_def mkIde_set by simp
finally show ?thesis by auto
qed
lemma dom_mkArr [simp]:
assumes "arr (mkArr A B F)"
shows "dom (mkArr A B F) = mkIde A"
using assms Fun_mkArr' by auto
lemma cod_mkArr [simp]:
assumes "arr (mkArr A B F)"
shows "cod (mkArr A B F) = mkIde B"
using assms Fun_mkArr' by auto
lemma Fun_mkArr [simp]:
assumes "arr (mkArr A B F)"
shows "Fun (mkArr A B F) = restrict F A"
using assms Fun_mkArr' by auto
text‹
The following provides the basic technique for showing that arrows
constructed using @{term mkArr} are equal.
›
lemma mkArr_eqI [intro]:
assumes "arr (mkArr A B F)"
and "A = A'" and "B = B'" and "⋀x. x ∈ A ⟹ F x = F' x"
shows "mkArr A B F = mkArr A' B' F'"
using assms arr_mkArr Fun_mkArr
by (intro arr_eqI, auto simp add: Pi_iff)
text‹
This version avoids trivial proof obligations when the domain and codomain
sets are identical from the context.
›
lemma mkArr_eqI' [intro]:
assumes "arr (mkArr A B F)" and "⋀x. x ∈ A ⟹ F x = F' x"
shows "mkArr A B F = mkArr A B F'"
using assms mkArr_eqI arr_mkArr by simp
lemma mkArr_restrict_eq:
assumes "arr (mkArr A B F)"
shows "mkArr A B (restrict F A) = mkArr A B F"
using assms arr_mkArr by (intro mkArr_eqI', auto)
lemma mkArr_restrict_eq':
assumes "arr (mkArr A B (restrict F A))"
shows "mkArr A B (restrict F A) = mkArr A B F"
using assms by (intro mkArr_eqI', auto)
lemma mkIde_as_mkArr:
assumes "A ⊆ Univ" and "|A| <o 𝔄"
shows "mkArr A A (λx. x) = mkIde A"
using assms arr_mkIde arr_mkArr dom_mkIde cod_mkIde Fun_mkIde
by (intro arr_eqI, auto)
lemma comp_mkArr:
assumes "arr (mkArr A B F)" and "arr (mkArr B C G)"
shows "mkArr B C G ⋅ mkArr A B F = mkArr A C (G ∘ F)"
proof (intro arr_eqI)
have 1: "seq (mkArr B C G) (mkArr A B F)" using assms by force
have 2: "G o F ∈ A → C" using assms arr_mkArr by auto
show "par (mkArr B C G ⋅ mkArr A B F) (mkArr A C (G ∘ F))"
using assms 1 2 arr_mkArr
by (intro conjI) simp_all
show "Fun (mkArr B C G ⋅ mkArr A B F) = Fun (mkArr A C (G ∘ F))"
using 1 2 arr_mkArr set_mkIde by fastforce
qed
text‹
The locale assumption @{prop stable_img} forces @{term "t ∈ set t"} in case
@{term t} is a terminal object. This is very convenient, as it results in the
characterization of terminal objects as identities @{term t} for which
@{term "set t = {t}"}. However, it is not absolutely necessary to have this.
The following weaker characterization of terminal objects can be proved without
the @{prop stable_img} assumption.
›
lemma terminal_char1:
shows "terminal t ⟷ ide t ∧ (∃!x. x ∈ set t)"
proof -
have "terminal t ⟹ ide t ∧ (∃!x. x ∈ set t)"
proof -
assume t: "terminal t"
have "ide t" using t terminal_def by auto
moreover have "∃!x. x ∈ set t"
proof -
have "∃!x. x ∈ hom unity t"
using t terminal_unity terminal_def by auto
thus ?thesis using set_def by auto
qed
ultimately show "ide t ∧ (∃!x. x ∈ set t)" by auto
qed
moreover have "ide t ∧ (∃!x. x ∈ set t) ⟹ terminal t"
proof -
assume t: "ide t ∧ (∃!x. x ∈ set t)"
from this obtain t' where "set t = {t'}" by blast
hence t': "set t = {t'} ∧ {t'} ⊆ Univ ∧ t = mkIde {t'}"
using t set_subset_Univ mkIde_set by metis
show "terminal t"
proof
show "ide t" using t by simp
show "⋀a. ide a ⟹ ∃!f. «f : a → t»"
proof -
fix a
assume a: "ide a"
show "∃!f. «f : a → t»"
proof
show 1: "«mkArr (set a) {t'} (λx. t') : a → t»"
proof
show 2: "arr (mkArr (set a) {t'} (λx. t'))"
using a t t' cardinal set_card mkIde_set set_subset_Univ arr_mkArr
by force
show "dom (mkArr (set a) {t'} (λx. t')) = a"
using a 2 mkIde_set by simp
show "cod (mkArr (set a) {t'} (λx. t')) = t"
using t t' 2 by simp
qed
show "⋀f. «f : a → t» ⟹ f = mkArr (set a) {t'} (λx. t')"
proof -
fix f
assume f: "«f : a → t»"
show "f = mkArr (set a) {t'} (λx. t')"
proof (intro arr_eqI)
show 1: "par f (mkArr (set a) {t'} (λx. t'))" using 1 f in_homE by metis
show "Fun f = Fun (mkArr (set a) {t'} (λx. t'))"
proof -
have "Fun (mkArr (set a) {t'} (λx. t')) = (λx∈set a. t')"
using 1 Fun_mkArr by simp
also have "... = Fun f"
proof -
have "⋀x. x ∈ set a ⟹ Fun f x = t'"
using f t' Fun_def mkArr_Fun arr_mkArr
by (metis PiE in_homE singletonD)
moreover have "⋀x. x ∉ set a ⟹ Fun f x = undefined"
using f Fun_def by auto
ultimately show ?thesis by auto
qed
finally show ?thesis by force
qed
qed
qed
qed
qed
qed
qed
ultimately show ?thesis by blast
qed
text‹
As stated above, in the presence of the @{prop stable_img} assumption we have
the following stronger characterization of terminal objects.
›
lemma terminal_char2:
shows "terminal t ⟷ ide t ∧ set t = {t}"
proof
assume t: "terminal t"
show "ide t ∧ set t = {t}"
proof
show "ide t" using t terminal_char1 by auto
show "set t = {t}"
proof -
have "∃!x. x ∈ hom unity t" using t terminal_def terminal_unity by force
moreover have "t ∈ img ` hom unity t" using t stable_img set_def by simp
ultimately show ?thesis using set_def by auto
qed
qed
next
assume "ide t ∧ set t = {t}"
thus "terminal t" using terminal_char1 by force
qed
end
text‹
At last, we define the ‹set_category› locale by existentially quantifying
out the choice of a particular @{term img} map. We need to know that such a map
exists, but it does not matter which one we choose.
›
locale set_category = category S
for S :: "'s comp" (infixr "⋅" 55)
and 𝔄 :: "'t rel" +
assumes ex_img: "∃img. set_category_given_img S img 𝔄"
begin
notation in_hom ("«_ : _ → _»")
definition some_img
where "some_img = (SOME img. set_category_given_img S img 𝔄)"
end
sublocale set_category ⊆ set_category_given_img S some_img 𝔄
proof -
have "∃img. set_category_given_img S img 𝔄" using ex_img by auto
thus "set_category_given_img S some_img 𝔄"
using someI_ex [of "λimg. set_category_given_img S img 𝔄"] some_img_def
by metis
qed
text‹
For a set category, if the cardinal ‹𝔄› is large enough, then it imposes no constraint
on what subsets of the universe determine objects. In this case, we call the set category
\emph{replete} and we can eliminate the cardinality assumptions from various facts.
›
locale replete_set_category =
set_category S ‹cardSuc (cmax (card_of (UNIV :: 's set)) natLeq)›
for S :: "'s comp" (infixr "⋅" 55)
begin
lemma card_of_leq:
assumes "A ⊆ Univ"
shows "|A| <o cardSuc (cmax (card_of (UNIV :: 's set)) natLeq)"
proof -
have "|A| ≤o cmax (card_of (UNIV :: 's set)) natLeq"
using assms card_of_Card_order natLeq_Card_order ordLeq_cmax1
ordLeq_transitive
by (metis card_of_UNIV)
thus ?thesis
by (simp add: Card_order_cmax natLeq_Card_order)
qed
lemma set_mkIde [simp]:
assumes "A ⊆ Univ"
shows "set (mkIde A) = A"
using assms card_of_leq set_mkIde by simp
lemma ide_mkIde [simp]:
assumes "A ⊆ Univ"
shows "ide (mkIde A)"
using assms card_of_leq ide_mkIde by simp
lemma arr_mkIde [iff]:
shows "arr (mkIde A) ⟷ A ⊆ Univ"
using card_of_leq arr_mkIde by auto
lemma dom_mkIde [simp]:
assumes "A ⊆ Univ"
shows "dom (mkIde A) = mkIde A"
using assms ide_mkIde by simp
lemma cod_mkIde [simp]:
assumes "A ⊆ Univ"
shows "cod (mkIde A) = mkIde A"
using assms ide_mkIde by simp
lemma Fun_mkIde [simp]:
assumes "A ⊆ Univ"
shows "Fun (mkIde A) = restrict (λx. x) A"
using assms set_mkIde ide_mkIde Fun_ide by simp
lemma mkArr_in_hom [intro]:
assumes "A ⊆ Univ" and "B ⊆ Univ" and "F ∈ A → B"
shows "«mkArr A B F : mkIde A → mkIde B»"
using assms card_of_leq arr_mkArr by auto
lemma arr_mkArr:
shows "arr (mkArr A B F) ⟷ A ⊆ Univ ∧ B ⊆ Univ ∧ F ∈ A → B"
using card_of_leq arr_mkArr by auto
lemma mkIde_as_mkArr:
assumes "A ⊆ Univ"
shows "mkArr A A (λx. x) = mkIde A"
using assms card_of_leq set_mkIde arr_mkIde arr_mkArr dom_mkIde cod_mkIde Fun_mkIde
by (intro arr_eqI, auto)
end
context set_category
begin
text‹
The arbitrary choice of @{term img} induces a system of arrows corresponding
to inclusions of subsets.
›
definition incl :: "'s ⇒ bool"
where "incl f = (arr f ∧ set (dom f) ⊆ set (cod f) ∧
f = mkArr (set (dom f)) (set (cod f)) (λx. x))"
lemma Fun_incl:
assumes "incl f"
shows "Fun f = (λx ∈ set (dom f). x)"
using assms incl_def by (metis Fun_mkArr)
lemma ex_incl_iff_subset:
assumes "ide a" and "ide b"
shows "(∃f. «f : a → b» ∧ incl f) ⟷ set a ⊆ set b"
proof
show "∃f. «f : a → b» ∧ incl f ⟹ set a ⊆ set b"
using incl_def by auto
show "set a ⊆ set b ⟹ ∃f. «f : a → b» ∧ incl f"
proof
assume 1: "set a ⊆ set b"
show "«mkArr (set a) (set b) (λx. x) : a → b» ∧ incl (mkArr (set a) (set b) (λx. x))"
proof
show "«mkArr (set a) (set b) (λx. x) : a → b»"
proof -
have "(λx. x) ∈ set a → set b" using 1 by auto
thus ?thesis
using assms mkArr_in_hom set_subset_Univ in_homI set_card arr_mkArr mkIde_set
by auto
qed
thus "incl (mkArr (set a) (set b) (λx. x))"
using 1 incl_def by force
qed
qed
qed
end
section "Categoricity"
text‹
In this section we show that the ‹set_category› locale completely characterizes
the structure of its interpretations as categories, in the sense that for any two
interpretations @{term S} and @{term S'} for the same cardinal ‹𝔄›,
a bijection between the universe of @{term S} and the universe of @{term S'} extends
to an isomorphism of @{term S} and @{term S'}.
›
locale two_set_categories_bij_betw_Univ =
S: set_category S 𝔄 +
S': set_category S' 𝔄
for S :: "'s comp" (infixr "⋅" 55)
and S' :: "'t comp" (infixr "⋅´" 55)
and 𝔄 :: "'u rel"
and φ :: "'s ⇒ 't" +
assumes bij_φ: "bij_betw φ S.Univ S'.Univ"
begin
notation S.in_hom ("«_ : _ → _»")
notation S'.in_hom ("«_ : _ →'' _»")
abbreviation ψ
where "ψ ≡ inv_into S.Univ φ"
lemma ψ_φ:
assumes "t ∈ S.Univ"
shows "ψ (φ t) = t"
using assms bij_φ bij_betw_inv_into_left by metis
lemma φ_ψ:
assumes "t' ∈ S'.Univ"
shows "φ (ψ t') = t'"
using assms bij_φ bij_betw_inv_into_right by metis
lemma ψ_img_φ_img:
assumes "A ⊆ S.Univ"
shows "ψ ` φ ` A = A"
using assms bij_φ by (simp add: bij_betw_def)
lemma φ_img_ψ_img:
assumes "A' ⊆ S'.Univ"
shows "φ ` ψ ` A' = A'"
using assms bij_φ by (simp add: bij_betw_def image_inv_into_cancel)
text‹
We define the object map @{term Φo} of a functor from @{term[source=true] S}
to @{term[source=true] S'}.
›
definition Φo
where "Φo = (λa ∈ Collect S.ide. S'.mkIde (φ ` S.set a))"
lemma set_Φo:
assumes "S.ide a"
shows "S'.set (Φo a) = φ ` S.set a"
proof -
from assms have "S.set a ⊆ S.Univ ∧ |S.set a| <o 𝔄"
by (simp add: S.set_card)
moreover have "|φ ` S.set a| <o 𝔄"
by (meson calculation card_of_image ordLeq_ordLess_trans)
ultimately show ?thesis
using S'.set_mkIde Φo_def assms bij_φ bij_betw_def image_mono mem_Collect_eq restrict_def
by (metis (no_types, lifting))
qed
lemma Φo_preserves_ide:
assumes "S.ide a"
shows "S'.ide (Φo a)"
using assms S'.ide_mkIde S.set_subset_Univ bij_φ bij_betw_def image_mono restrict_apply'
unfolding Φo_def
by (metis (no_types, lifting) S.set_card card_of_image mem_Collect_eq ordLeq_ordLess_trans)
text‹
The map @{term Φa} assigns to each arrow @{term f} of @{term[source=true] S} the function on
the universe of @{term[source=true] S'} that is the same as the function induced by @{term f}
on the universe of @{term[source=true] S}, up to the bijection @{term φ} between the two
universes.
›
definition Φa
where "Φa = (λf. λx' ∈ φ ` S.set (S.dom f). φ (S.Fun f (ψ x')))"
lemma Φa_mapsto:
assumes "S.arr f"
shows "Φa f ∈ S'.set (Φo (S.dom f)) → S'.set (Φo (S.cod f))"
proof -
have "Φa f ∈ φ ` S.set (S.dom f) → φ ` S.set (S.cod f)"
proof
fix x
assume x: "x ∈ φ ` S.set (S.dom f)"
have "ψ x ∈ S.set (S.dom f)"
using assms x ψ_img_φ_img [of "S.set (S.dom f)"] S.set_subset_Univ by auto
hence "S.Fun f (ψ x) ∈ S.set (S.cod f)" using assms S.Fun_mapsto by auto
hence "φ (S.Fun f (ψ x)) ∈ φ ` S.set (S.cod f)" by simp
thus "Φa f x ∈ φ ` S.set (S.cod f)" using x Φa_def by auto
qed
thus ?thesis using assms set_Φo Φo_preserves_ide by auto
qed
text‹
The map @{term Φa} takes composition of arrows to extensional
composition of functions.
›
lemma Φa_comp:
assumes gf: "S.seq g f"
shows "Φa (g ⋅ f) = restrict (Φa g o Φa f) (S'.set (Φo (S.dom f)))"
proof -
have "Φa (g ⋅ f) = (λx' ∈ φ ` S.set (S.dom f). φ (S.Fun (S g f) (ψ x')))"
using gf Φa_def by auto
also have "... = (λx' ∈ φ ` S.set (S.dom f).
φ (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (ψ x')))"
using gf set_Φo S.Fun_comp by simp
also have "... = restrict (Φa g o Φa f) (S'.set (Φo (S.dom f)))"
proof -
have "⋀x'. x' ∈ φ ` S.set (S.dom f)
⟹ φ (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (ψ x')) = Φa g (Φa f x')"
proof -
fix x'
assume X': "x' ∈ φ ` S.set (S.dom f)"
hence 1: "ψ x' ∈ S.set (S.dom f)"
using gf ψ_img_φ_img [of "S.set (S.dom f)"] S.set_subset_Univ S.ide_dom by blast
hence "φ (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (ψ x'))
= φ (S.Fun g (S.Fun f (ψ x')))"
using restrict_apply by auto
also have "... = φ (S.Fun g (ψ (φ (S.Fun f (ψ x')))))"
proof -
have "S.Fun f (ψ x') ∈ S.set (S.cod f)"
using gf 1 S.Fun_mapsto by fast
hence "ψ (φ (S.Fun f (ψ x'))) = S.Fun f (ψ x')"
using assms bij_φ S.set_subset_Univ bij_betw_def inv_into_f_f subsetCE S.ide_cod
by (metis S.seqE)
thus ?thesis by auto
qed
also have "... = Φa g (Φa f x')"
proof -
have "Φa f x' ∈ φ ` S.set (S.cod f)"
using gf S.ide_dom S.ide_cod X' Φa_mapsto [of f] set_Φo [of "S.dom f"]
set_Φo [of "S.cod f"]
by blast
thus ?thesis using gf X' Φa_def by auto
qed
finally show "φ (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (ψ x')) =
Φa g (Φa f x')"
by auto
qed
thus ?thesis using assms set_Φo by fastforce
qed
finally show ?thesis by auto
qed
text‹
Finally, we use @{term Φo} and @{term Φa} to define a functor @{term Φ}.
›
definition Φ
where "Φ f = (if S.arr f then
S'.mkArr (S'.set (Φo (S.dom f))) (S'.set (Φo (S.cod f))) (Φa f)
else S'.null)"
lemma Φ_in_hom:
assumes "S.arr f"
shows "Φ f ∈ S'.hom (Φo (S.dom f)) (Φo (S.cod f))"
proof -
have "«Φ f : S'.dom (Φ f) →' S'.cod (Φ f)»"
using assms Φ_def [of f] Φa_mapsto [of f] Φo_preserves_ide S'.set_card S'.arr_mkArr
by (intro S'.in_homI) auto
thus ?thesis
using assms Φ_def Φa_mapsto Φo_preserves_ide S'.set_card S'.arr_mkArr S'.mkIde_set
by auto
qed
lemma Φ_ide [simp]:
assumes "S.ide a"
shows "Φ a = Φo a"
proof -
have "Φ a = S'.mkArr (S'.set (Φo a)) (S'.set (Φo a)) (λx'. x')"
proof -
have "«Φ a : Φo a →' Φo a»"
using assms Φ_in_hom S.ide_in_hom by fastforce
moreover have "Φa a = restrict (λx'. x') (S'.set (Φo a))"
proof -
have "Φa a = (λx' ∈ φ ` S.set a. φ (S.Fun a (ψ x')))"
using assms Φa_def restrict_apply by auto
also have "... = (λx' ∈ S'.set (Φo a). φ (ψ x'))"
proof -
have "S.Fun a = (λx ∈ S.set a. x)" using assms S.Fun_ide by simp
moreover have "⋀x'. x' ∈ φ ` S.set a ⟹ ψ x' ∈ S.set a"
using assms bij_φ S.set_subset_Univ image_iff by (metis ψ_img_φ_img)
ultimately show ?thesis
using assms set_Φo by auto
qed
also have "... = restrict (λx'. x') (S'.set (Φo a))"
using assms S'.set_subset_Univ Φo_preserves_ide φ_ψ
by (meson restr_eqI subsetCE)
ultimately show ?thesis by auto
qed
ultimately show ?thesis
using assms Φ_def Φo_preserves_ide S'.mkArr_restrict_eq'
by (metis S'.arrI S.ide_char)
qed
thus ?thesis
using assms S'.mkIde_as_mkArr Φo_preserves_ide Φ_in_hom S'.set_card S'.mkIde_set
by simp
qed
lemma set_dom_Φ:
assumes "S.arr f"
shows "S'.set (S'.dom (Φ f)) = φ ` (S.set (S.dom f))"
using assms S.ide_dom Φ_in_hom Φ_ide set_Φo by fastforce
lemma Φ_comp:
assumes "S.seq g f"
shows "Φ (g ⋅ f) = Φ g ⋅´ Φ f"
proof -
have "Φ (g ⋅ f) = S'.mkArr (S'.set (Φo (S.dom f))) (S'.set (Φo (S.cod g))) (Φa (S g f))"
using Φ_def assms by auto
also have "... = S'.mkArr (S'.set (Φo (S.dom f))) (S'.set (Φo (S.cod g)))
(restrict (Φa g o Φa f) (S'.set (Φo (S.dom f))))"
using assms Φa_comp set_Φo by force
also have "... = S'.mkArr (S'.set (Φo (S.dom f))) (S'.set (Φo (S.cod g))) (Φa g o Φa f)"
proof -
have "S'.arr (S'.mkArr (S'.set (Φo (S.dom f))) (S'.set (Φo (S.cod g))) (Φa g o Φa f))"
using assms Φa_mapsto [of f] Φa_mapsto [of g] Φo_preserves_ide S'.arr_mkArr S'.set_card
by (elim S.seqE, auto)
thus ?thesis
using assms S'.mkArr_restrict_eq by auto
qed
also have "... = S' (S'.mkArr (S'.set (Φo (S.dom g))) (S'.set (Φo (S.cod g))) (Φa g))
(S'.mkArr (S'.set (Φo (S.dom f))) (S'.set (Φo (S.cod f))) (Φa f))"
proof -
have "S'.arr (S'.mkArr (S'.set (Φo (S.dom f))) (S'.set (Φo (S.cod f))) (Φa f))"
using assms Φa_mapsto set_Φo S.ide_dom S.ide_cod Φo_preserves_ide
S'.arr_mkArr S'.set_subset_Univ S.seqE S'.set_card
by metis
moreover have "S'.arr (S'.mkArr (S'.set (Φo (S.dom g))) (S'.set (Φo (S.cod g)))
(Φa g))"
using assms Φa_mapsto set_Φo S.ide_dom S.ide_cod Φo_preserves_ide S'.arr_mkArr
S'.set_subset_Univ S.seqE S'.set_card
by metis
ultimately show ?thesis using assms S'.comp_mkArr by force
qed
also have "... = Φ g ⋅´ Φ f" using assms Φ_def by force
finally show ?thesis by fast
qed
interpretation Φ: "functor" S S' Φ
apply unfold_locales
using Φ_def
apply simp
using Φ_in_hom Φ_comp
by auto
lemma Φ_is_functor:
shows "functor S S' Φ" ..
lemma Fun_Φ:
assumes "S.arr f" and "x ∈ S.set (S.dom f)"
shows "S'.Fun (Φ f) (φ x) = Φa f (φ x)"
using assms Φ_def Φ.preserves_arr set_Φo by auto
lemma Φ_acts_elementwise:
assumes "S.ide a"
shows "S'.set (Φ a) = Φ ` S.set a"
proof
have 0: "S'.set (Φ a) = φ ` S.set a"
using assms Φ_ide set_Φo by simp
have 1: "⋀x. x ∈ S.set a ⟹ Φ x = φ x"
proof -
fix x
assume x: "x ∈ S.set a"
have 1: "S.terminal x" using assms x S.set_subset_Univ by blast
hence 2: "S'.terminal (φ x)"
by (metis CollectD CollectI bij_φ bij_betw_def image_iff)
have "Φ x = Φo x"
using assms x 1 Φ_ide S.terminal_def by auto
also have "... = φ x"
proof -
have "Φo x = S'.mkIde (φ ` S.set x)"
using assms 1 x Φo_def S.terminal_def by auto
moreover have "S'.mkIde (φ ` S.set x) = φ x"
using assms x 1 2 S.terminal_char2 S'.terminal_char2 S'.mkIde_set bij_φ
by (metis image_empty image_insert)
ultimately show ?thesis by auto
qed
finally show "Φ x = φ x" by auto
qed
show "S'.set (Φ a) ⊆ Φ ` S.set a" using 0 1 by force
show "Φ ` S.set a ⊆ S'.set (Φ a)" using 0 1 by force
qed
lemma Φ_preserves_incl:
assumes "S.incl m"
shows "S'.incl (Φ m)"
proof -
have 1: "S.arr m ∧ S.set (S.dom m) ⊆ S.set (S.cod m) ∧
m = S.mkArr (S.set (S.dom m)) (S.set (S.cod m)) (λx. x)"
using assms S.incl_def by blast
have "S'.arr (Φ m)" using 1 by auto
moreover have 2: "S'.set (S'.dom (Φ m)) ⊆ S'.set (S'.cod (Φ m))"
using 1 Φ.preserves_dom Φ.preserves_cod Φ_acts_elementwise
by (metis (full_types) S.ide_cod S.ide_dom image_mono)
moreover have "Φ m =
S'.mkArr (S'.set (S'.dom (Φ m))) (S'.set (S'.cod (Φ m))) (λx'. x')"
proof -
have "Φ m = S'.mkArr (S'.set (Φo (S.dom m))) (S'.set (Φo (S.cod m))) (Φa m)"
using 1 Φ_def by simp
also have "... = S'.mkArr (S'.set (S'.dom (Φ m))) (S'.set (S'.cod (Φ m))) (Φa m)"
using 1 Φ_ide by auto
finally have 3: "Φ m =
S'.mkArr (S'.set (S'.dom (Φ m))) (S'.set (S'.cod (Φ m))) (Φa m)"
by auto
also have "... = S'.mkArr (S'.set (S'.dom (Φ m))) (S'.set (S'.cod (Φ m))) (λx'. x')"
proof -
have 4: "S.Fun m = restrict (λx. x) (S.set (S.dom m))"
using assms S.incl_def by (metis (full_types) S.Fun_mkArr)
hence "Φa m = restrict (λx'. x') (φ ` (S.set (S.dom m)))"
proof -
have 5: "⋀x'. x' ∈ φ ` S.set (S.dom m) ⟹ φ (ψ x') = x'"
by (metis 1 S'.set_subset_Univ S.ide_dom Φo_preserves_ide φ_ψ set_Φo subsetD)
have "Φa m = restrict (λx'. φ (S.Fun m (ψ x'))) (φ ` S.set (S.dom m))"
using Φa_def by simp
also have "... = restrict (λx'. x') (φ ` S.set (S.dom m))"
proof -
have "⋀x. x ∈ φ ` (S.set (S.dom m)) ⟹ φ (S.Fun m (ψ x)) = x"
proof -
fix x
assume x: "x ∈ φ ` (S.set (S.dom m))"
hence "ψ x ∈ S.set (S.dom m)"
using 1 S.ide_dom S.set_subset_Univ ψ_img_φ_img image_eqI by metis
thus "φ (S.Fun m (ψ x)) = x" using 1 4 5 x by simp
qed
thus ?thesis by auto
qed
finally show ?thesis by auto
qed
hence "Φa m = restrict (λx'. x') (S'.set (S'.dom (Φ m)))"
using 1 set_dom_Φ by auto
thus ?thesis
using 2 3 ‹S'.arr (Φ m)› S'.mkArr_restrict_eq S'.ide_cod S'.ide_dom S'.incl_def
by (metis S'.arr_mkArr image_restrict_eq image_subset_iff_funcset)
qed
finally show ?thesis by auto
qed
ultimately show ?thesis using S'.incl_def by blast
qed
text‹
Interchange the role of @{term φ} and @{term ψ} to obtain a functor ‹Ψ›
from @{term[source=true] S'} to @{term[source=true] S}.
›
interpretation INV: two_set_categories_bij_betw_Univ S' S 𝔄 ψ
apply unfold_locales by (simp add: bij_φ bij_betw_inv_into)
abbreviation Ψo
where "Ψo ≡ INV.Φo"
abbreviation Ψa
where "Ψa ≡ INV.Φa"
abbreviation Ψ
where "Ψ ≡ INV.Φ"
interpretation Ψ: "functor" S' S Ψ
using INV.Φ_is_functor by auto
text‹
The functors @{term Φ} and @{term Ψ} are inverses.
›
lemma Fun_Ψ:
assumes "S'.arr f'" and "x' ∈ S'.set (S'.dom f')"
shows "S.Fun (Ψ f') (ψ x') = Ψa f' (ψ x')"
using assms INV.Fun_Φ by blast
lemma Ψo_Φo:
assumes "S.ide a"
shows "Ψo (Φo a) = a"
using assms Φo_def INV.Φo_def ψ_img_φ_img Φo_preserves_ide set_Φo S.mkIde_set
by force
lemma ΦΨ:
assumes "S.arr f"
shows "Ψ (Φ f) = f"
proof (intro S.arr_eqI)
show par: "S.par (Ψ (Φ f)) f"
using assms Φo_preserves_ide Ψo_Φo by auto
show "S.Fun (Ψ (Φ f)) = S.Fun f"
proof -
have "S.arr (Ψ (Φ f))" using assms by auto
moreover have "Ψ (Φ f) = S.mkArr (S.set (S.dom f)) (S.set (S.cod f)) (Ψa (Φ f))"
using assms INV.Φ_def Φ_in_hom Ψo_Φo by auto
moreover have "Ψa (Φ f) = (λx ∈ S.set (S.dom f). ψ (S'.Fun (Φ f) (φ x)))"
proof -
have "Ψa (Φ f) = (λx ∈ ψ ` S'.set (S'.dom (Φ f)). ψ (S'.Fun (Φ f) (φ x)))"
proof -
have "⋀x. x ∈ ψ ` S'.set (S'.dom (Φ f)) ⟹ INV.ψ x = φ x"
using assms S.ide_dom S.set_subset_Univ Ψ.preserves_reflects_arr par bij_φ
inv_into_inv_into_eq subsetCE INV.set_dom_Φ
by metis
thus ?thesis
using INV.Φa_def by auto
qed
moreover have "ψ ` S'.set (S'.dom (Φ f)) = S.set (S.dom f)"
using assms by (metis par Ψ.preserves_reflects_arr INV.set_dom_Φ)
ultimately show ?thesis by auto
qed
ultimately have 1: "S.Fun (Ψ (Φ f)) = (λx ∈ S.set (S.dom f). ψ (S'.Fun (Φ f) (φ x)))"
using S'.Fun_mkArr by simp
show ?thesis
proof
fix x
have "x ∉ S.set (S.dom f) ⟹ S.Fun (Ψ (Φ f)) x = S.Fun f x"
using 1 assms extensional_def S.Fun_mapsto S.Fun_def by auto
moreover have "x ∈ S.set (S.dom f) ⟹ S.Fun (Ψ (Φ f)) x = S.Fun f x"
proof -
assume x: "x ∈ S.set (S.dom f)"
have "S.Fun (Ψ (Φ f)) x = ψ (φ (S.Fun f (ψ (φ x))))"
using assms x 1 Fun_Φ bij_φ Φa_def by auto
also have "... = S.Fun f x"
proof -
have 2: "⋀x. x ∈ S.Univ ⟹ ψ (φ x) = x"
using bij_φ bij_betw_inv_into_left by fast
have "S.Fun f (ψ (φ x)) = S.Fun f x"
using assms x 2
by (metis S.ide_dom S.set_subset_Univ subsetCE)
moreover have "S.Fun f x ∈ S.Univ"
using x assms S.Fun_mapsto S.set_subset_Univ S.ide_cod by blast
ultimately show ?thesis using 2 by auto
qed
finally show ?thesis by auto
qed
ultimately show "S.Fun (Ψ (Φ f)) x = S.Fun f x" by auto
qed
qed
qed
lemma Φo_Ψo:
assumes "S'.ide a'"
shows "Φo (Ψo a') = a'"
using assms Φo_def INV.Φo_def φ_img_ψ_img INV.Φo_preserves_ide ψ_φ INV.set_Φo
S'.mkIde_set
by force
lemma ΨΦ:
assumes "S'.arr f'"
shows "Φ (Ψ f') = f'"
proof (intro S'.arr_eqI)
show par: "S'.par (Φ (Ψ f')) f'"
using assms Φ.preserves_ide Ψ.preserves_ide Φ_ide INV.Φ_ide Φo_Ψo by auto
show "S'.Fun (Φ (Ψ f')) = S'.Fun f'"
proof -
have "S'.arr (Φ (Ψ f'))" using assms by blast
moreover have "Φ (Ψ f') =
S'.mkArr (S'.set (S'.dom f')) (S'.set (S'.cod f')) (Φa (Ψ f'))"
using assms Φ_def INV.Φ_in_hom Φo_Ψo by simp
moreover have "Φa (Ψ f') = (λx' ∈ S'.set (S'.dom f'). φ (S.Fun (Ψ f') (ψ x')))"
unfolding Φa_def
using assms par Ψ.preserves_arr set_dom_Φ by metis
ultimately have 1: "S'.Fun (Φ (Ψ f')) =
(λx' ∈ S'.set (S'.dom f'). φ (S.Fun (Ψ f') (ψ x')))"
using S'.Fun_mkArr by simp
show ?thesis
proof
fix x'
have "x' ∉ S'.set (S'.dom f') ⟹ S'.Fun (Φ (Ψ f')) x' = S'.Fun f' x'"
using 1 assms S'.Fun_mapsto extensional_def by (simp add: S'.Fun_def)
moreover have "x' ∈ S'.set (S'.dom f') ⟹ S'.Fun (Φ (Ψ f')) x' = S'.Fun f' x'"
proof -
assume x': "x' ∈ S'.set (S'.dom f')"
have "S'.Fun (Φ (Ψ f')) x' = φ (S.Fun (Ψ f') (ψ x'))"
using x' 1 by auto
also have "... = φ (Ψa f' (ψ x'))"
using Fun_Ψ x' assms S'.set_subset_Univ bij_φ by metis
also have "... = φ (ψ (S'.Fun f' (φ (ψ x'))))"
proof -
have "φ (Ψa f' (ψ x')) = φ (ψ (S'.Fun f' x'))"
proof -
have "x' ∈ S'.Univ"
by (meson S'.ide_dom S'.set_subset_Univ assms subsetCE x')
thus ?thesis
by (simp add: INV.Φa_def INV.ψ_φ x')
qed
also have "... = φ (ψ (S'.Fun f' (φ (ψ x'))))"
using assms x' φ_ψ S'.set_subset_Univ S'.ide_dom by (metis subsetCE)
finally show ?thesis by auto
qed
also have "... = S'.Fun f' x'"
proof -
have 2: "⋀x'. x' ∈ S'.Univ ⟹ φ (ψ x') = x'"
using bij_φ bij_betw_inv_into_right by fast
have "S'.Fun f' (φ (ψ x')) = S'.Fun f' x'"
using assms x' 2 S'.set_subset_Univ S'.ide_dom by (metis subsetCE)
moreover have "S'.Fun f' x' ∈ S'.Univ"
using x' assms S'.Fun_mapsto S'.set_subset_Univ S'.ide_cod by blast
ultimately show ?thesis using 2 by auto
qed
finally show ?thesis by auto
qed
ultimately show "S'.Fun (Φ (Ψ f')) x' = S'.Fun f' x'" by auto
qed
qed
qed
lemma inverse_functors_Φ_Ψ:
shows "inverse_functors S S' Ψ Φ"
proof -
interpret ΦΨ: composite_functor S S' S Φ Ψ ..
have inv: "Ψ o Φ = S.map"
using ΦΨ S.map_def ΦΨ.is_extensional by auto
interpret ΨΦ: composite_functor S' S S' Ψ Φ ..
have inv': "Φ o Ψ = S'.map"
using ΨΦ S'.map_def ΨΦ.is_extensional by auto
show ?thesis
using inv inv' by (unfold_locales, auto)
qed
lemma are_isomorphic:
shows "∃Φ. invertible_functor S S' Φ ∧ (∀m. S.incl m ⟶ S'.incl (Φ m))"
proof -
interpret inverse_functors S S' Ψ Φ
using inverse_functors_Φ_Ψ by auto
have 1: "inverse_functors S S' Ψ Φ" ..
interpret invertible_functor S S' Φ
apply unfold_locales using 1 by auto
have "invertible_functor S S' Φ" ..
thus ?thesis using Φ_preserves_incl by auto
qed
end
text‹
The main result: @{locale set_category} is categorical, in the following (logical) sense:
If ‹S› and ‹S'› are two ``set categories'' for the same cardinal ‹𝔄›,
and if the sets of terminal objects of ‹S› and ‹S'› are in bijective correspondence,
then ‹S› and ‹S'› are isomorphic as categories, via a functor that preserves inclusion maps,
hence the inclusion relation between sets.
›
theorem set_category_is_categorical:
assumes "set_category S 𝔄" and "set_category S' 𝔄"
and "bij_betw φ (set_category_data.Univ S) (set_category_data.Univ S')"
shows "∃Φ. invertible_functor S S' Φ ∧
(∀m. set_category.incl S 𝔄 m ⟶ set_category.incl S' 𝔄 (Φ m))"
proof -
interpret S: set_category S using assms(1) by auto
interpret S': set_category S' using assms(2) by auto
interpret two_set_categories_bij_betw_Univ S S' 𝔄 φ
apply (unfold_locales) using assms(3) by auto
show ?thesis using are_isomorphic by auto
qed
section "Further Properties of Set Categories"
text‹
In this section we further develop the consequences of the ‹set_category›
axioms, and establish characterizations of a number of standard category-theoretic
notions for a ‹set_category›.
›
context set_category
begin
abbreviation Dom
where "Dom f ≡ set (dom f)"
abbreviation Cod
where "Cod f ≡ set (cod f)"
subsection "Initial Object"
text‹
The object corresponding to the empty set is an initial object.
›
definition empty
where "empty = mkIde {}"
lemma initial_empty:
shows "initial empty"
proof
show 0: "ide empty"
using empty_def ide_mkIde
by (simp add: ide_mkIde_finite)
show "⋀b. ide b ⟹ ∃!f. «f : empty → b»"
proof -
fix b
assume b: "ide b"
show "∃!f. «f : empty → b»"
proof
show 1: "«mkArr {} (set b) (λx. x) : empty → b»"
using 0 b empty_def mkArr_in_hom mkIde_set set_subset_Univ arr_mkIde
by (metis (no_types, lifting) Pi_I empty_iff ide_def mkIde_def)
show "⋀f. «f : empty → b» ⟹ f = mkArr {} (set b) (λx. x)"
proof -
fix f
assume f: "«f : empty → b»"
show "f = mkArr {} (set b) (λx. x)"
proof (intro arr_eqI)
show 1: "par f (mkArr {} (set b) (λx. x))"
using 1 f by force
show "Fun f = Fun (mkArr {} (set b) (λx. x))"
using empty_def 1 f Fun_mapsto arr_mkArr set_mkIde by fastforce
qed
qed
qed
qed
qed
subsection "Identity Arrows"
text‹
Identity arrows correspond to restrictions of the identity function.
›
lemma ide_char:
assumes "arr f"
shows "ide f ⟷ Dom f = Cod f ∧ Fun f = (λx ∈ Dom f. x)"
using assms mkIde_as_mkArr mkArr_Fun Fun_ide in_homE ide_cod mkArr_Fun mkIde_set
by (metis ide_char)
lemma ideI:
assumes "arr f" and "Dom f = Cod f" and "⋀x. x ∈ Dom f ⟹ Fun f x = x"
shows "ide f"
proof -
have "Fun f = (λx ∈ Dom f. x)"
using assms Fun_def by auto
thus ?thesis using assms ide_char by blast
qed
subsection "Inclusions"
lemma ide_implies_incl:
assumes "ide a"
shows "incl a"
proof -
have "arr a ∧ Dom a ⊆ Cod a" using assms by auto
moreover have "a = mkArr (Dom a) (Cod a) (λx. x)"
using assms mkIde_as_mkArr mkIde_set set_card by simp
ultimately show ?thesis using incl_def by simp
qed
definition incl_in :: "'s ⇒ 's ⇒ bool"
where "incl_in a b = (ide a ∧ ide b ∧ set a ⊆ set b)"
abbreviation incl_of
where "incl_of a b ≡ mkArr (set a) (set b) (λx. x)"
lemma elem_set_implies_set_eq_singleton:
assumes "a ∈ set b"
shows "set a = {a}"
proof -
have "ide b" using assms set_def by auto
thus ?thesis using assms set_subset_Univ terminal_char2
by (metis mem_Collect_eq subsetCE)
qed
lemma elem_set_implies_incl_in:
assumes "a ∈ set b"
shows "incl_in a b"
proof -
have b: "ide b" using assms set_def by auto
hence "set b ⊆ Univ" by simp
hence "a ∈ Univ ∧ set a ⊆ set b"
using assms elem_set_implies_set_eq_singleton by auto
hence "ide a ∧ set a ⊆ set b"
using b terminal_char1 by simp
thus ?thesis using b incl_in_def by simp
qed
lemma incl_incl_of [simp]:
assumes "incl_in a b"
shows "incl (incl_of a b)"
and "«incl_of a b : a → b»"
proof -
show "«incl_of a b : a → b»"
using assms incl_in_def mkArr_in_hom mkIde_set set_subset_Univ
by (metis image_ident image_subset_iff_funcset set_card)
thus "incl (incl_of a b)"
using assms incl_def incl_in_def by fastforce
qed
text‹
There is at most one inclusion between any pair of objects.
›
lemma incls_coherent:
assumes "par f f'" and "incl f" and "incl f'"
shows "f = f'"
using assms incl_def fun_complete by auto
text‹
The set of inclusions is closed under composition.
›
lemma incl_comp [simp]:
assumes "incl f" and "incl g" and "cod f = dom g"
shows "incl (g ⋅ f)"
proof -
have 1: "seq g f" using assms incl_def by auto
moreover have 2: "Dom (g ⋅ f) ⊆ Cod (g ⋅ f)"
using assms 1 incl_def by auto
moreover have "g ⋅ f = mkArr (Dom f) (Cod g) (restrict (λx. x) (Dom f))"
proof (intro arr_eqI)
have 3: "arr (mkArr (Dom f) (Cod g) (λx∈Dom f. x))"
using assms 1 2
by (metis cod_comp dom_comp ex_incl_iff_subset ide_cod ide_dom
in_homE incl_def mkArr_restrict_eq)
show 4: "par (g ⋅ f) (mkArr (Dom f) (Cod g) (λx∈Dom f. x))"
using assms 1 3 mkIde_set by auto
show "Fun (g ⋅ f) = Fun (mkArr (Dom f) (Cod g) (λx∈Dom f. x))"
using assms 3 4 Fun_comp Fun_mkArr
by (metis Fun_ide comp_cod_arr ide_cod mkArr_restrict_eq' incl_def)
qed
ultimately show ?thesis using incl_def arr_mkArr set_mkIde by force
qed
subsection "Image Factorization"
text‹
The image of an arrow is the object that corresponds to the set-theoretic
image of the domain set under the function induced by the arrow.
›
abbreviation Img
where "Img f ≡ Fun f ` Dom f"
definition img
where "img f = mkIde (Img f)"
lemma ide_img [simp]:
assumes "arr f"
shows "ide (img f)"
proof -
have "Fun f ` Dom f ⊆ Cod f" using assms Fun_mapsto by blast
moreover have "Cod f ⊆ Univ ∧ |Cod f| <o 𝔄"
using assms by (simp add: set_card)
ultimately have "Fun f ` Dom f ⊆ Univ ∧ |Fun f ` Dom f| <o 𝔄"
by (meson assms card_of_image ide_dom ordLeq_ordLess_trans set_card subset_eq)
thus ?thesis using img_def ide_mkIde by simp
qed
lemma set_img [simp]:
assumes "arr f"
shows "set (img f) = Img f"
proof -
have "Fun f ` set (dom f) ⊆ set (cod f) ∧ set (cod f) ⊆ Univ"
using assms Fun_mapsto by auto
hence "Fun f ` set (dom f) ⊆ Univ ∧ |Fun f ` Dom f| <o 𝔄"
by (metis assms ide_def ide_img img_def mkIde_def)
thus ?thesis using assms img_def set_mkIde by auto
qed
lemma img_point_in_Univ:
assumes "«x : unity → a»"
shows "img x ∈ Univ"
proof -
have "set (img x) = {Fun x unity}"
using assms img_def terminal_unity terminal_char2
image_empty image_insert mem_Collect_eq set_img
by force
thus "img x ∈ Univ" using assms terminal_char1 by auto
qed
lemma incl_in_img_cod:
assumes "arr f"
shows "incl_in (img f) (cod f)"
proof (unfold img_def)
have 1: "Img f ⊆ Cod f ∧ Cod f ⊆ Univ ∧ |Cod f| <o 𝔄"
using assms Fun_mapsto
by (metis arr_mkArr image_subset_iff_funcset mkArr_Fun)
hence 2: "ide (mkIde (Img f))"
using assms ide_img img_def by auto
moreover have "set (mkIde (Img f)) ⊆ Cod f"
using 1 2
by (metis ideD(1) arr_mkIde set_mkIde)
ultimately show "incl_in (mkIde (Img f)) (cod f)"
using assms incl_in_def ide_cod by blast
qed
lemma img_point_elem_set:
assumes "«x : unity → a»"
shows "img x ∈ set a"
proof -
have "incl_in (img x) a"
using assms incl_in_img_cod by auto
hence "set (img x) ⊆ set a"
using incl_in_def by blast
moreover have "img x ∈ set (img x)"
using assms img_point_in_Univ terminal_char2 by simp
ultimately show ?thesis by auto
qed
text‹
The corestriction of an arrow @{term f} is the arrow
@{term "corestr f ∈ hom (dom f) (img f)"} that induces the same function
on the universe as @{term f}.
›
definition corestr
where "corestr f = mkArr (Dom f) (Img f) (Fun f)"
lemma corestr_in_hom:
assumes "arr f"
shows "«corestr f : dom f → img f»"
proof -
have "Fun f ∈ Dom f → Fun f ` Dom f ∧ Dom f ⊆ Univ"
using assms by auto
moreover have "Fun f ` Dom f ⊆ Univ"
proof -
have "Fun f ` Dom f ⊆ Cod f ∧ Cod f ⊆ Univ"
using assms Fun_mapsto by auto
thus ?thesis by blast
qed
moreover have "|Fun f ` Dom f| <o 𝔄"
using assms by (metis ide_img set_card set_img)
ultimately have "mkArr (Dom f) (Fun f ` Dom f) (Fun f) ∈ hom (dom f) (img f)"
using assms img_def mkArr_in_hom [of "Dom f" "Fun f ` Dom f" "Fun f"] mkIde_set
by (simp add: set_card)
thus ?thesis using corestr_def by fastforce
qed
text‹
Every arrow factors as a corestriction followed by an inclusion.
›
lemma img_fact:
assumes "arr f"
shows "S (incl_of (img f) (cod f)) (corestr f) = f"
proof (intro arr_eqI)
have 1: "«corestr f : dom f → img f»"
using assms corestr_in_hom by blast
moreover have 2: "«incl_of (img f) (cod f) : img f → cod f»"
using assms incl_in_img_cod incl_incl_of by fast
ultimately show P: "par (incl_of (img f) (cod f) ⋅ corestr f) f"
using assms in_homE by blast
show "Fun (incl_of (img f) (cod f) ⋅ corestr f) = Fun f"
proof -
have "Fun (incl_of (img f) (cod f) ⋅ corestr f)
= restrict (Fun (incl_of (img f) (cod f)) o Fun (corestr f)) (Dom f)"
using Fun_comp 1 2 P by auto
also have
"... = restrict (restrict (λx. x) (Img f) o restrict (Fun f) (Dom f)) (Dom f)"
proof -
have "Fun (corestr f) = restrict (Fun f) (Dom f)"
using assms corestr_def Fun_mkArr corestr_in_hom by force
moreover have "Fun (incl_of (img f) (cod f)) = restrict (λx. x) (Img f)"
proof -
have "arr (incl_of (img f) (cod f))" using incl_incl_of P by blast
moreover have "incl_of (img f) (cod f) = mkArr (Img f) (Cod f) (λx. x)"
using assms by fastforce
ultimately show ?thesis using assms img_def Fun_mkArr by metis
qed
ultimately show ?thesis by argo
qed
also have "... = Fun f"
proof
fix x
show "restrict (restrict (λx. x) (Img f) o restrict (Fun f) (Dom f)) (Dom f) x = Fun f x"
using assms extensional_restrict Fun_mapsto extensional_arb [of "Fun f" "Dom f" x]
by (cases "x ∈ Dom f", auto)
qed
finally show ?thesis by auto
qed
qed
lemma Fun_corestr:
assumes "arr f"
shows "Fun (corestr f) = Fun f"
proof -
have 1: "f = incl_of (img f) (cod f) ⋅ corestr f"
using assms img_fact by auto
hence 2: "Fun f = restrict (Fun (incl_of (img f) (cod f)) o Fun (corestr f)) (Dom f)"
using assms by (metis Fun_comp dom_comp)
also have "... = restrict (Fun (corestr f)) (Dom f)"
using assms by (metis 1 2 Fun_mkArr seqE mkArr_Fun corestr_def)
also have "... = Fun (corestr f)"
using assms 1 by (metis Fun_def dom_comp extensional_restrict restrict_extensional)
finally show ?thesis by auto
qed
subsection "Points and Terminal Objects"
text‹
To each element @{term t} of @{term "set a"} is associated a point
@{term "mkPoint a t ∈ hom unity a"}. The function induced by such
a point is the constant-@{term t} function on the set @{term "{unity}"}.
›
definition mkPoint
where "mkPoint a t ≡ mkArr {unity} (set a) (λ_. t)"
lemma mkPoint_in_hom:
assumes "ide a" and "t ∈ set a"
shows "«mkPoint a t : unity → a»"
using assms mkArr_in_hom mkIde_set set_subset_Univ terminal_char2 terminal_unity
mkPoint_def set_card
by (metis Pi_I)
lemma Fun_mkPoint:
assumes "ide a" and "t ∈ set a"
shows "Fun (mkPoint a t) = (λ_ ∈ {unity}. t)"
using assms mkPoint_def mkPoint_in_hom Fun_mkArr by force
text‹
For each object @{term a} the function @{term "mkPoint a"} has as its inverse
the restriction of the function @{term img} to @{term "hom unity a"}
›
lemma mkPoint_img:
shows "img ∈ hom unity a → set a"
and "⋀x. «x : unity → a» ⟹ mkPoint a (img x) = x"
proof -
show "img ∈ hom unity a → set a"
using img_point_elem_set by simp
show "⋀x. «x : unity → a» ⟹ mkPoint a (img x) = x"
proof -
fix x
assume x: "«x : unity → a»"
show "mkPoint a (img x) = x"
proof (intro arr_eqI)
have 0: "img x ∈ set a"
using x img_point_elem_set by metis
hence 1: "mkPoint a (img x) ∈ hom unity a"
using x mkPoint_in_hom by force
thus 2: "par (mkPoint a (img x)) x"
using x by fastforce
have "Fun (mkPoint a (img x)) = (λ_ ∈ {unity}. img x)"
using 1 mkPoint_def by auto
also have "... = Fun x"
proof
fix z
have "z ≠ unity ⟹ (λ_ ∈ {unity}. img x) z = Fun x z"
using x Fun_mapsto Fun_def restrict_apply singletonD terminal_char2 terminal_unity
by auto
moreover have "(λ_ ∈ {unity}. img x) unity = Fun x unity"
proof -
have "(λ_ ∈ {unity}. img x) unity = img x"
by simp
also have "... = Fun x unity"
using x 0 elem_set_implies_set_eq_singleton set_img terminal_char2 terminal_unity
by (metis (no_types, lifting) image_insert in_homE singleton_insert_inj_eq')
finally show ?thesis by blast
qed
ultimately show "(λ_ ∈ {unity}. img x) z = Fun x z" by auto
qed
finally show "Fun (mkPoint a (img x)) = Fun x" by auto
qed
qed
qed
lemma img_mkPoint:
assumes "ide a"
shows "mkPoint a ∈ set a → hom unity a"
and "⋀t. t ∈ set a ⟹ img (mkPoint a t) = t"
proof -
show "mkPoint a ∈ set a → hom unity a"
using assms(1) mkPoint_in_hom by simp
show "⋀t. t ∈ set a ⟹ img (mkPoint a t) = t"
proof -
fix t
assume t: "t ∈ set a"
show "img (mkPoint a t) = t"
proof -
have 1: "arr (mkPoint a t)"
using assms t mkPoint_in_hom by auto
have "Fun (mkPoint a t) ` {unity} = {t}"
using 1 mkPoint_def by simp
thus ?thesis
by (metis 1 t elem_set_implies_incl_in elem_set_implies_set_eq_singleton img_def
incl_in_def dom_mkArr mkIde_set terminal_char2 terminal_unity mkPoint_def)
qed
qed
qed
text‹
For each object @{term a} the elements of @{term "hom unity a"} are therefore in
bijective correspondence with @{term "set a"}.
›
lemma bij_betw_points_and_set:
assumes "ide a"
shows "bij_betw img (hom unity a) (set a)"
proof (intro bij_betwI)
show "img ∈ hom unity a → set a"
using assms mkPoint_img by auto
show "mkPoint a ∈ set a → hom unity a"
using assms img_mkPoint by auto
show "⋀x. x ∈ hom unity a ⟹ mkPoint a (img x) = x"
using assms mkPoint_img by auto
show "⋀t. t ∈ set a ⟹ img (mkPoint a t) = t"
using assms img_mkPoint by auto
qed
text‹
The function on the universe induced by an arrow @{term f} agrees, under the bijection
between @{term "hom unity (dom f)"} and @{term "Dom f"}, with the action of @{term f}
by composition on @{term "hom unity (dom f)"}.
›
lemma Fun_point:
assumes "«x : unity → a»"
shows "Fun x = (λ_ ∈ {unity}. img x)"
using assms mkPoint_img img_mkPoint Fun_mkPoint [of a "img x"] img_point_elem_set
by auto
lemma comp_arr_mkPoint:
assumes "arr f" and "t ∈ Dom f"
shows "f ⋅ mkPoint (dom f) t = mkPoint (cod f) (Fun f t)"
proof (intro arr_eqI)
have 0: "seq f (mkPoint (dom f) t)"
using assms mkPoint_in_hom [of "dom f" t] by auto
have 1: "«f ⋅ mkPoint (dom f) t : unity → cod f»"
using assms mkPoint_in_hom [of "dom f" t] by auto
show "par (f ⋅ mkPoint (dom f) t) (mkPoint (cod f) (Fun f t))"
proof -
have "«mkPoint (cod f) (Fun f t) : unity → cod f»"
using assms Fun_mapsto mkPoint_in_hom [of "cod f" "Fun f t"] by auto
thus ?thesis using 1 by fastforce
qed
show "Fun (f ⋅ mkPoint (dom f) t) = Fun (mkPoint (cod f) (Fun f t))"
proof -
have "Fun (f ⋅ mkPoint (dom f) t) = restrict (Fun f o Fun (mkPoint (dom f) t)) {unity}"
using assms 0 1 Fun_comp terminal_char2 terminal_unity by auto
also have "... = (λ_ ∈ {unity}. Fun f t)"
using assms Fun_mkPoint by auto
also have "... = Fun (mkPoint (cod f) (Fun f t))"
using assms Fun_mkPoint [of "cod f" "Fun f t"] Fun_mapsto by fastforce
finally show ?thesis by auto
qed
qed
lemma comp_arr_point:
assumes "arr f" and "«x : unity → dom f»"
shows "f ⋅ x = mkPoint (cod f) (Fun f (img x))"
proof -
have "x = mkPoint (dom f) (img x)" using assms mkPoint_img by simp
thus ?thesis using assms comp_arr_mkPoint [of f "img x"]
by (simp add: img_point_elem_set)
qed
text‹
This agreement allows us to express @{term "Fun f"} in terms of composition.
›
lemma Fun_in_terms_of_comp:
assumes "arr f"
shows "Fun f = restrict (img o S f o mkPoint (dom f)) (Dom f)"
proof
fix t
have "t ∉ Dom f ⟹ Fun f t = restrict (img o S f o mkPoint (dom f)) (Dom f) t"
using assms by (simp add: Fun_def)
moreover have "t ∈ Dom f ⟹
Fun f t = restrict (img o S f o mkPoint (dom f)) (Dom f) t"
proof -
assume t: "t ∈ Dom f"
have 1: "f ⋅ mkPoint (dom f) t = mkPoint (cod f) (Fun f t)"
using assms t comp_arr_mkPoint by simp
hence "img (f ⋅ mkPoint (dom f) t) = img (mkPoint (cod f) (Fun f t))" by simp
thus ?thesis
proof -
have "Fun f t ∈ Cod f" using assms t Fun_mapsto by auto
thus ?thesis using assms t 1 img_mkPoint by auto
qed
qed
ultimately show "Fun f t = restrict (img o S f o mkPoint (dom f)) (Dom f) t" by auto
qed
text‹
We therefore obtain a rule for proving parallel arrows equal by showing
that they have the same action by composition on points.
›
lemma arr_eqI':
assumes "par f f'" and "⋀x. «x : unity → dom f» ⟹ f ⋅ x = f' ⋅ x"
shows "f = f'"
using assms Fun_in_terms_of_comp mkPoint_in_hom by (intro arr_eqI, auto)
text‹
An arrow can therefore be specified by giving its action by composition on points.
In many situations, this is more natural than specifying it as a function on the universe.
›
definition mkArr'
where "mkArr' a b F = mkArr (set a) (set b) (img o F o mkPoint a)"
lemma mkArr'_in_hom:
assumes "ide a" and "ide b" and "F ∈ hom unity a → hom unity b"
shows "«mkArr' a b F : a → b»"
proof -
have "img o F o mkPoint a ∈ set a → set b"
proof
fix t
assume t: "t ∈ set a"
thus "(img o F o mkPoint a) t ∈ set b"
using assms mkPoint_in_hom img_point_elem_set [of "F (mkPoint a t)" b]
by auto
qed
thus ?thesis
using assms mkArr'_def mkArr_in_hom [of "set a" "set b"] set_card mkIde_set by simp
qed
lemma comp_point_mkArr':
assumes "ide a" and "ide b" and "F ∈ hom unity a → hom unity b"
shows "⋀x. «x : unity → a» ⟹ mkArr' a b F ⋅ x = F x"
proof -
fix x
assume x: "«x : unity → a»"
have "Fun (mkArr' a b F) (img x) = img (F x)"
unfolding mkArr'_def
using assms x Fun_mkArr arr_mkArr img_point_elem_set mkPoint_img mkPoint_in_hom
by (simp add: set_card Pi_iff)
hence "mkArr' a b F ⋅ x = mkPoint b (img (F x))"
using assms x mkArr'_in_hom [of a b F] comp_arr_point by auto
thus "mkArr' a b F ⋅ x = F x"
using assms x mkPoint_img(2) by auto
qed
text‹
A third characterization of terminal objects is as those objects whose set of
points is a singleton.
›
lemma terminal_char3:
assumes "∃!x. «x : unity → a»"
shows "terminal a"
proof -
have a: "ide a"
using assms ide_cod mem_Collect_eq by blast
hence 1: "bij_betw img (hom unity a) (set a)"
using assms bij_betw_points_and_set by auto
hence "img ` (hom unity a) = set a"
by (simp add: bij_betw_def)
moreover have "hom unity a = {THE x. x ∈ hom unity a}"
using assms theI' [of "λx. x ∈ hom unity a"] by auto
ultimately have "set a = {img (THE x. x ∈ hom unity a)}"
by (metis image_empty image_insert)
thus ?thesis using a terminal_char1 by simp
qed
text‹
The following is an alternative formulation of functional completeness, which says that
any function on points uniquely determines an arrow.
›
lemma fun_complete':
assumes "ide a" and "ide b" and "F ∈ hom unity a → hom unity b"
shows "∃!f. «f : a → b» ∧ (∀x. «x : unity → a» ⟶ f ⋅ x = F x)"
proof
have 1: "«mkArr' a b F : a → b»" using assms mkArr'_in_hom by auto
moreover have 2: "⋀x. «x : unity → a» ⟹ mkArr' a b F ⋅ x = F x"
using assms comp_point_mkArr' by auto
ultimately show "«mkArr' a b F : a → b» ∧
(∀x. «x : unity → a» ⟶ mkArr' a b F ⋅ x = F x)" by blast
fix f
assume f: "«f : a → b» ∧ (∀x. «x : unity → a» ⟶ f ⋅ x = F x)"
show "f = mkArr' a b F"
using f 1 2 by (intro arr_eqI' [of f "mkArr' a b F"], fastforce, auto)
qed
subsection "The `Determines Same Function' Relation on Arrows"
text‹
An important part of understanding the structure of a category of sets and functions
is to characterize when it is that two arrows ``determine the same function''.
The following result provides one answer to this: two arrows with a common domain
determine the same function if and only if they can be rendered equal by composing with
a cospan of inclusions.
›
lemma eq_Fun_iff_incl_joinable:
assumes "span f f'"
shows "Fun f = Fun f' ⟷
(∃m m'. incl m ∧ incl m' ∧ seq m f ∧ seq m' f' ∧ m ⋅ f = m' ⋅ f')"
proof
assume ff': "Fun f = Fun f'"
let ?b = "mkIde (Cod f ∪ Cod f')"
let ?m = "incl_of (cod f) ?b"
let ?m' = "incl_of (cod f') ?b"
have 1: "|Cod f ∪ Cod f'| <o 𝔄"
using assms set_card cardinal card_order_infinite_isLimOrd by simp
have incl_m: "incl ?m"
using assms 1 incl_incl_of [of "cod f" ?b] incl_in_def ide_mkIde set_mkIde by simp
have incl_m': "incl ?m'"
using assms 1 incl_incl_of [of "cod f'" ?b] incl_in_def ide_mkIde set_mkIde by simp
have m: "?m = mkArr (Cod f) (Cod f ∪ Cod f') (λx. x)"
by (simp add: assms 1 set_mkIde)
have m': "?m' = mkArr (Cod f') (Cod f ∪ Cod f') (λx. x)"
by (simp add: assms 1 set_mkIde)
have seq: "seq ?m f ∧ seq ?m' f'"
using assms m m'
by (metis ide_cod incl_m incl_m' mkIde_set seqI incl_def dom_mkArr)
have "?m ⋅ f = ?m' ⋅ f'"
proof (intro arr_eqI)
show par: "par (?m ⋅ f) (?m' ⋅ f')"
using assms m m'
by (metis cod_comp cod_mkArr dom_comp seq seqE)
show "Fun (?m ⋅ f) = Fun (?m' ⋅ f')"
using assms ff'
by (metis incl_m incl_m' comp_mkArr incl_def mkArr_Fun)
qed
hence "incl ?m ∧ incl ?m' ∧ seq ?m f ∧ seq ?m' f' ∧ ?m ⋅ f = ?m' ⋅ f'"
using seq ‹incl ?m› ‹incl ?m'› by simp
thus "∃m m'. incl m ∧ incl m' ∧ seq m f ∧ seq m' f' ∧ m ⋅ f = m' ⋅ f'" by auto
next
assume ff': "∃m m'. incl m ∧ incl m' ∧ seq m f ∧ seq m' f' ∧ m ⋅ f = m' ⋅ f'"
show "Fun f = Fun f'"
using ff'
by (metis Fun_comp Fun_ide comp_cod_arr ide_cod seqE Fun_incl)
qed
text‹
Another answer to the same question: two arrows with a common domain determine the
same function if and only if their corestrictions are equal.
›
lemma eq_Fun_iff_eq_corestr:
assumes "span f f'"
shows "Fun f = Fun f' ⟷ corestr f = corestr f'"
using assms corestr_def Fun_corestr by metis
subsection "Retractions, Sections, and Isomorphisms"
text‹
An arrow is a retraction if and only if its image coincides with its codomain.
›
lemma retraction_if_Img_eq_Cod:
assumes "arr g" and "Img g = Cod g"
shows "retraction g"
and "ide (g ⋅ mkArr (Cod g) (Dom g) (inv_into (Dom g) (Fun g)))"
proof -
let ?F = "inv_into (Dom g) (Fun g)"
let ?f = "mkArr (Cod g) (Dom g) ?F"
have f: "arr ?f"
proof -
have "Cod g ⊆ Univ ∧ Dom g ⊆ Univ" using assms by auto
moreover have "|Cod g| <o 𝔄 ∧ |Dom g| <o 𝔄"
using assms by (simp add: set_card)
moreover have "?F ∈ Cod g → Dom g"
proof
fix y
assume y: "y ∈ Cod g"
let ?P = "λx. x ∈ Dom g ∧ Fun g x = y"
have "∃x. ?P x" using y assms by force
hence "?P (SOME x. ?P x)" using someI_ex [of ?P] by fast
hence "?P (?F y)" using Hilbert_Choice.inv_into_def by metis
thus "?F y ∈ Dom g" by auto
qed
ultimately show ?thesis
using arr_mkArr by auto
qed
show "ide (g ⋅ ?f)"
proof -
have "g = mkArr (Dom g) (Cod g) (Fun g)" using assms mkArr_Fun by auto
hence "g ⋅ ?f = mkArr (Cod g) (Cod g) (Fun g o ?F)"
using assms(1) f comp_mkArr by metis
moreover have "mkArr (Cod g) (Cod g) (λy. y) = ..."
proof (intro mkArr_eqI')
show "arr (mkArr (Cod g) (Cod g) (λy. y))"
using assms arr_cod_iff_arr set_card arr_mkArr by auto
show "⋀y. y ∈ Cod g ⟹ y = (Fun g o ?F) y"
using assms by (simp add: f_inv_into_f)
qed
ultimately show ?thesis
using assms f mkIde_as_mkArr arr_mkArr mkIde_set by auto
qed
thus "retraction g" by auto
qed
lemma retraction_char:
shows "retraction g ⟷ arr g ∧ Img g = Cod g"
proof
assume G: "retraction g"
show "arr g ∧ Img g = Cod g"
proof
show "arr g" using G by blast
show "Img g = Cod g"
proof -
from G obtain f where f: "ide (g ⋅ f)" by blast
have "restrict (Fun g o Fun f) (Cod g) = restrict (λx. x) (Cod g)"
using f Fun_comp Fun_ide ide_compE by metis
hence "Fun g ` Fun f ` Cod g = Cod g"
by (metis image_comp image_ident image_restrict_eq)
moreover have "Fun f ` Cod g ⊆ Dom g"
using f Fun_mapsto arr_mkArr mkArr_Fun funcset_image
by (metis seqE ide_compE ide_compE)
moreover have "Img g ⊆ Cod g"
using f Fun_mapsto by blast
ultimately show ?thesis by blast
qed
qed
next
assume "arr g ∧ Img g = Cod g"
thus "retraction g" using retraction_if_Img_eq_Cod by blast
qed
text‹
Every corestriction is a retraction.
›
lemma retraction_corestr:
assumes "arr f"
shows "retraction (corestr f)"
using assms retraction_char Fun_corestr corestr_in_hom arr_mkArr by force
text‹
An arrow is a section if and only if it induces an injective function on its
domain, except in the special case that it has an empty domain set and a
nonempty codomain set.
›
lemma section_if_inj:
assumes "arr f" and "inj_on (Fun f) (Dom f)" and "Dom f = {} ⟶ Cod f = {}"
shows "section f"
and "ide (mkArr (Cod f) (Dom f)
(λy. if y ∈ Img f then SOME x. x ∈ Dom f ∧ Fun f x = y
else SOME x. x ∈ Dom f)
⋅ f)"
proof -
let ?P= "λy. λx. x ∈ Dom f ∧ Fun f x = y"
let ?G = "λy. if y ∈ Img f then SOME x. ?P y x else SOME x. x ∈ Dom f"
let ?g = "mkArr (Cod f) (Dom f) ?G"
have g: "arr ?g"
proof -
have 1: "Cod f ⊆ Univ" using assms by simp
have 2: "Dom f ⊆ Univ" using assms by simp
have 3: "|Cod f| <o 𝔄 ∧ |Dom f| <o 𝔄"
using assms set_card by simp
have 4: "?G ∈ Cod f → Dom f"
proof
fix y
assume Y: "y ∈ Cod f"
show "?G y ∈ Dom f"
proof (cases "y ∈ Img f")
assume "y ∈ Img f"
hence "(∃x. ?P y x) ∧ ?G y = (SOME x. ?P y x)" using Y by auto
hence "?P y (?G y)" using someI_ex [of "?P y"] by argo
thus "?G y ∈ Dom f" by auto
next
assume "y ∉ Img f"
hence "(∃x. x ∈ Dom f) ∧ ?G y = (SOME x. x ∈ Dom f)" using assms Y by auto
thus "?G y ∈ Dom f" using someI_ex [of "λx. x ∈ Dom f"] by argo
qed
qed
show ?thesis using 1 2 3 4 arr_mkArr by simp
qed
show "ide (?g ⋅ f)"
proof -
have "f = mkArr (Dom f) (Cod f) (Fun f)" using assms mkArr_Fun by auto
hence "?g ⋅ f = mkArr (Dom f) (Dom f) (?G o Fun f)"
using assms(1) g comp_mkArr [of "Dom f" "Cod f" "Fun f" "Dom f" ?G] by argo
moreover have "mkArr (Dom f) (Dom f) (λx. x) = ..."
proof (intro mkArr_eqI')
show "arr (mkArr (Dom f) (Dom f) (λx. x))"
using assms set_card arr_mkArr by auto
show "⋀x. x ∈ Dom f ⟹ x = (?G o Fun f) x"
proof -
fix x
assume x: "x ∈ Dom f"
have "Fun f x ∈ Img f" using x by blast
hence *: "(∃x'. ?P (Fun f x) x') ∧ ?G (Fun f x) = (SOME x'. ?P (Fun f x) x')"
by auto
then have "?P (Fun f x) (?G (Fun f x))"
using someI_ex [of "?P (Fun f x)"] by argo
with * have "x = ?G (Fun f x)"
using assms x inj_on_def [of "Fun f" "Dom f"] by simp
thus "x = (?G o Fun f) x" by simp
qed
qed
ultimately show ?thesis
using assms set_card mkIde_as_mkArr mkIde_set by auto
qed
thus "section f" by auto
qed
lemma section_char:
shows "section f ⟷ arr f ∧ (Dom f = {} ⟶ Cod f = {}) ∧ inj_on (Fun f) (Dom f)"
proof
assume f: "section f"
from f obtain g where g: "ide (g ⋅ f)" using section_def by blast
show "arr f ∧ (Dom f = {} ⟶ Cod f = {}) ∧ inj_on (Fun f) (Dom f)"
proof -
have "arr f" using f by blast
moreover have "Dom f = {} ⟶ Cod f = {}"
proof -
have "Cod f ≠ {} ⟶ Dom f ≠ {}"
proof
assume "Cod f ≠ {}"
from this obtain y where "y ∈ Cod f" by blast
hence "Fun g y ∈ Dom f"
using g Fun_mapsto
by (metis seqE ide_compE image_eqI retractionI retraction_char)
thus "Dom f ≠ {}" by blast
qed
thus ?thesis by auto
qed
moreover have "inj_on (Fun f) (Dom f)"
proof -
have "restrict (Fun g o Fun f) (Dom f) = Fun (g ⋅ f)"
using g Fun_comp by (metis Fun_comp ide_compE)
also have "... = restrict (λx. x) (Dom f)"
using g Fun_ide by auto
finally have "restrict (Fun g o Fun f) (Dom f) = restrict (λx. x) (Dom f)" by auto
thus ?thesis using inj_onI inj_on_imageI2 inj_on_restrict_eq by metis
qed
ultimately show ?thesis by auto
qed
next
assume F: "arr f ∧ (Dom f = {} ⟶ Cod f = {}) ∧ inj_on (Fun f) (Dom f)"
thus "section f" using section_if_inj by auto
qed
text‹
Section-retraction pairs can also be characterized by an inverse relationship
between the functions they induce.
›
lemma section_retraction_char:
shows "ide (g ⋅ f) ⟷ antipar f g ∧ compose (Dom f) (Fun g) (Fun f) = (λx ∈ Dom f. x)"
proof
show "ide (g ⋅ f) ⟹ antipar f g ∧ compose (Dom f) (Fun g) (Fun f) = (λx ∈ Dom f. x)"
proof -
assume fg: "ide (g ⋅ f)"
have 1: "antipar f g" using fg by force
moreover have "compose (Dom f) (Fun g) (Fun f) = (λx ∈ Dom f. x)"
proof
fix x
have "x ∉ Dom f ⟹ compose (Dom f) (Fun g) (Fun f) x = (λx ∈ Dom f. x) x"
by (simp add: compose_def)
moreover have "x ∈ Dom f ⟹
compose (Dom f) (Fun g) (Fun f) x = (λx ∈ Dom f. x) x"
using fg 1 Fun_comp by (metis Fun_comp Fun_ide compose_eq' ide_compE)
ultimately show "compose (Dom f) (Fun g) (Fun f) x = (λx ∈ Dom f. x) x" by auto
qed
ultimately show ?thesis by auto
qed
show "antipar f g ∧ compose (Dom f) (Fun g) (Fun f) = (λx ∈ Dom f. x) ⟹ ide (g ⋅ f)"
proof -
assume fg: "antipar f g ∧ compose (Dom f) (Fun g) (Fun f) = (λx ∈ Dom f. x)"
show "ide (g ⋅ f)"
proof -
have 1: "arr (g ⋅ f)" using fg by auto
moreover have "Dom (g ⋅ f) = Cod (S g f)"
using fg 1 by force
moreover have "Fun (g ⋅ f) = (λx ∈ Dom (g ⋅ f). x)"
using fg 1 by force
ultimately show ?thesis using 1 ide_char by blast
qed
qed
qed
text‹
Antiparallel arrows @{term f} and @{term g} are inverses if the functions
they induce are inverses.
›
lemma inverse_arrows_char:
shows "inverse_arrows f g ⟷
antipar f g ∧ compose (Dom f) (Fun g) (Fun f) = (λx ∈ Dom f. x)
∧ compose (Dom g) (Fun f) (Fun g) = (λy ∈ Dom g. y)"
using section_retraction_char by blast
text‹
An arrow is an isomorphism if and only if the function it induces is a bijection.
›
lemma iso_char:
shows "iso f ⟷ arr f ∧ bij_betw (Fun f) (Dom f) (Cod f)"
proof -
have "iso f ⟷ section f ∧ retraction f"
using iso_iff_section_and_retraction by auto
also have "... ⟷ arr f ∧ inj_on (Fun f) (Dom f) ∧ Img f = Cod f"
using section_char retraction_char by force
also have "... ⟷ arr f ∧ bij_betw (Fun f) (Dom f) (Cod f)"
using inj_on_def bij_betw_def [of "Fun f" "Dom f" "Cod f"] by meson
finally show ?thesis by auto
qed
text‹
The inverse of an isomorphism is constructed by inverting the induced function.
›
lemma inv_char:
assumes "iso f"
shows "inv f = mkArr (Cod f) (Dom f) (inv_into (Dom f) (Fun f))"
proof -
let ?g = "mkArr (Cod f) (Dom f) (inv_into (Dom f) (Fun f))"
have "ide (f ⋅ ?g)"
using assms iso_is_retraction retraction_char retraction_if_Img_eq_Cod by simp
moreover have "ide (?g ⋅ f)"
proof -
let ?g' = "mkArr (Cod f) (Dom f)
(λy. if y ∈ Img f then SOME x. x ∈ Dom f ∧ Fun f x = y
else SOME x. x ∈ Dom f)"
have 1: "ide (?g' ⋅ f)"
using assms iso_is_section section_char section_if_inj by simp
moreover have "?g' = ?g"
proof
show "arr ?g'" using 1 ide_compE by blast
show "⋀y. y ∈ Cod f ⟹ (if y ∈ Img f then SOME x. x ∈ Dom f ∧ Fun f x = y
else SOME x. x ∈ Dom f)
= inv_into (Dom f) (Fun f) y"
proof -
fix y
assume "y ∈ Cod f"
hence "y ∈ Img f" using assms iso_is_retraction retraction_char by metis
thus "(if y ∈ Img f then SOME x. x ∈ Dom f ∧ Fun f x = y
else SOME x. x ∈ Dom f)
= inv_into (Dom f) (Fun f) y"
using inv_into_def by metis
qed
qed
ultimately show ?thesis by auto
qed
ultimately have "inverse_arrows f ?g" by auto
thus ?thesis using inverse_unique by blast
qed
lemma Fun_inv:
assumes "iso f"
shows "Fun (inv f) = restrict (inv_into (Dom f) (Fun f)) (Cod f)"
using assms inv_in_hom inv_char iso_inv_iso iso_is_arr Fun_mkArr by metis
subsection "Monomorphisms and Epimorphisms"
text‹
An arrow is a monomorphism if and only if the function it induces is injective.
›
lemma mono_char:
shows "mono f ⟷ arr f ∧ inj_on (Fun f) (Dom f)"
proof
assume f: "mono f"
hence "arr f" using mono_def by auto
moreover have "inj_on (Fun f) (Dom f)"
proof (intro inj_onI)
have 0: "inj_on (S f) (hom unity (dom f))"
proof -
have "hom unity (dom f) ⊆ {g. seq f g}"
using f mono_def arrI by auto
hence "∃A. hom unity (dom f) ⊆ A ∧ inj_on (S f) A"
using f mono_def by auto
thus ?thesis
by (meson subset_inj_on)
qed
fix x x'
assume x: "x ∈ Dom f" and x': "x' ∈ Dom f" and xx': "Fun f x = Fun f x'"
have 1: "mkPoint (dom f) x ∈ hom unity (dom f) ∧
mkPoint (dom f) x' ∈ hom unity (dom f)"
using x x' ‹arr f› mkPoint_in_hom by simp
have "f ⋅ mkPoint (dom f) x = f ⋅ mkPoint (dom f) x'"
using ‹arr f› x x' xx' comp_arr_mkPoint by simp
hence "mkPoint (dom f) x = mkPoint (dom f) x'"
using 0 1 inj_onD [of "S f" "hom unity (dom f)" "mkPoint (dom f) x"] by simp
thus "x = x'"
using ‹arr f› x x' img_mkPoint(2) img_mkPoint(2) ide_dom by metis
qed
ultimately show "arr f ∧ inj_on (Fun f) (Dom f)" by auto
next
assume f: "arr f ∧ inj_on (Fun f) (Dom f)"
show "mono f"
proof
show "arr f" using f by auto
show "⋀g g'. seq f g ∧ seq f g' ∧ f ⋅ g = f ⋅ g' ⟹ g = g'"
proof -
fix g g'
assume gg': "seq f g ∧ seq f g' ∧ f ⋅ g = f ⋅ g'"
show "g = g'"
proof (intro arr_eqI)
show par: "par g g'"
using gg' dom_comp by (metis seqE)
show "Fun g = Fun g'"
proof
fix x
have "x ∉ Dom g ⟹ Fun g x = Fun g' x"
using gg' by (simp add: par Fun_def)
moreover have "x ∈ Dom g ⟹ Fun g x = Fun g' x"
proof -
assume x: "x ∈ Dom g"
have "Fun f (Fun g x) = Fun (f ⋅ g) x"
using gg' x Fun_comp [of f g] by auto
also have "... = Fun f (Fun g' x)"
using par f gg' x monoE by simp
finally have "Fun f (Fun g x) = Fun f (Fun g' x)" by auto
moreover have "Fun g x ∈ Dom f ∧ Fun g' x ∈ Dom f"
using par gg' x Fun_mapsto by fastforce
ultimately show "Fun g x = Fun g' x"
using f gg' inj_onD [of "Fun f" "Dom f" "Fun g x" "Fun g' x"]
by simp
qed
ultimately show "Fun g x = Fun g' x" by auto
qed
qed
qed
qed
qed
text‹
Inclusions are monomorphisms.
›
lemma mono_imp_incl:
assumes "incl f"
shows "mono f"
using assms incl_def Fun_incl mono_char by auto
text‹
A monomorphism is a section, except in case it has an empty domain set and
a nonempty codomain set.
›
lemma mono_imp_section:
assumes "mono f" and "Dom f = {} ⟶ Cod f = {}"
shows "section f"
using assms mono_char section_char by auto
text‹
An arrow is an epimorphism if and only if either its image coincides with its
codomain, or else the universe has only a single element (in which case all arrows
are epimorphisms).
›
lemma epi_char:
shows "epi f ⟷ arr f ∧ (Img f = Cod f ∨ (∀t t'. t ∈ Univ ∧ t' ∈ Univ ⟶ t = t'))"
proof
assume epi: "epi f"
show "arr f ∧ (Img f = Cod f ∨ (∀t t'. t ∈ Univ ∧ t' ∈ Univ ⟶ t = t'))"
proof -
have f: "arr f" using epi epi_implies_arr by auto
moreover have "¬(∀t t'. t ∈ Univ ∧ t' ∈ Univ ⟶ t = t') ⟹ Img f = Cod f"
proof -
assume "¬(∀t t'. t ∈ Univ ∧ t' ∈ Univ ⟶ t = t')"
from this obtain tt and ff
where B: "tt ∈ Univ ∧ ff ∈ Univ ∧ tt ≠ ff" by blast
show "Img f = Cod f"
proof
show "Img f ⊆ Cod f" using f Fun_mapsto by auto
show "Cod f ⊆ Img f"
proof
let ?g = "mkArr (Cod f) {ff, tt} (λy. tt)"
let ?g' = "mkArr (Cod f) {ff, tt} (λy. if ∃x. x ∈ Dom f ∧ Fun f x = y
then tt else ff)"
let ?b = "mkIde {ff, tt}"
have b: "ide ?b"
using B ide_mkIde_finite by simp
have g: "«?g : cod f → ?b» ∧ Fun ?g = (λy ∈ Cod f. tt)"
proof -
have "arr ?g"
proof -
have "arr (mkIde {ff, tt})"
using b ideD(1) by presburger
thus ?thesis
by (simp add: f set_card arr_mkIde arr_mkArr)
qed
thus ?thesis
using f b B in_homI [of ?g] mkIde_set by simp
qed
have g': "?g' ∈ hom (cod f) ?b ∧
Fun ?g' = (λy ∈ Cod f. if ∃x. x ∈ Dom f ∧ Fun f x = y then tt else ff)"
proof -
have "arr ?g"
proof -
have "arr (mkIde {ff, tt})"
using b ideD(1) by presburger
thus ?thesis
by (simp add: f set_card arr_mkIde arr_mkArr)
qed
thus ?thesis
using f b B in_homI [of ?g'] arr_mkArr mkIde_set by simp
qed
have "?g ⋅ f = ?g' ⋅ f"
proof (intro arr_eqI)
show "par (?g ⋅ f) (?g' ⋅ f)"
using f g g' arr_mkArr by auto
show "Fun (?g ⋅ f) = Fun (?g' ⋅ f)"
using f g g' Fun_comp comp_mkArr by fastforce
qed
hence gg': "?g = ?g'"
using epi f g g' epiE [of f ?g ?g'] by fastforce
fix y
assume y: "y ∈ Cod f"
have "Fun ?g' y = tt" using gg' g y by simp
hence "(if ∃x. x ∈ Dom f ∧ Fun f x = y then tt else ff) = tt"
using g' y by simp
hence "∃x. x ∈ Dom f ∧ Fun f x = y"
using B by argo
thus "y ∈ Img f" by blast
qed
qed
qed
ultimately show "arr f ∧ (Img f = Cod f ∨ (∀t t'. t ∈ Univ ∧ t' ∈ Univ ⟶ t = t'))"
by fast
qed
next
show "arr f ∧ (Img f = Cod f ∨ (∀t t'. t ∈ Univ ∧ t' ∈ Univ ⟶ t = t')) ⟹ epi f"
proof -
have "arr f ∧ Img f = Cod f ⟹ epi f"
proof -
assume f: "arr f ∧ Img f = Cod f"
show "epi f"
using f arr_eqI' epiE retractionI retraction_if_Img_eq_Cod retraction_is_epi
by meson
qed
moreover have "arr f ∧ (∀t t'. t ∈ Univ ∧ t' ∈ Univ ⟶ t = t') ⟹ epi f"
proof -
assume f: "arr f ∧ (∀t t'. t ∈ Univ ∧ t' ∈ Univ ⟶ t = t')"
have "⋀f f'. par f f' ⟹ f = f'"
proof -
fix f f'
assume ff': "par f f'"
show "f = f'"
proof (intro arr_eqI)
show "par f f'" using ff' by simp
have "⋀t t'. t ∈ Cod f ∧ t' ∈ Cod f ⟹ t = t'"
using f ff' set_subset_Univ ide_cod subsetD by blast
thus "Fun f = Fun f'"
using ff' Fun_mapsto [of f] Fun_mapsto [of f']
extensional_arb [of "Fun f" "Dom f"] extensional_arb [of "Fun f'" "Dom f"]
by fastforce
qed
qed
moreover have "⋀g g'. par (g ⋅ f) (g' ⋅ f) ⟹ par g g'"
by force
ultimately show "epi f"
using f by (intro epiI; metis)
qed
ultimately show "arr f ∧ (Img f = Cod f ∨ (∀t t'. t ∈ Univ ∧ t' ∈ Univ ⟶ t = t'))
⟹ epi f"
by auto
qed
qed
text‹
An epimorphism is a retraction, except in the case of a degenerate universe with only
a single element.
›
lemma epi_imp_retraction:
assumes "epi f" and "∃t t'. t ∈ Univ ∧ t' ∈ Univ ∧ t ≠ t'"
shows "retraction f"
using assms epi_char retraction_char by auto
text‹
Retraction/inclusion factorization is unique (not just up to isomorphism -- remember
that the notion of inclusion is not categorical but depends on the arbitrarily chosen
@{term img}).
›
lemma unique_retr_incl_fact:
assumes "seq m e" and "seq m' e'" and "m ⋅ e = m' ⋅ e'"
and "incl m" and "incl m'" and "retraction e" and "retraction e'"
shows "m = m'" and "e = e'"
proof -
have 1: "cod m = cod m' ∧ dom e = dom e'"
using assms(1-3) by (metis dom_comp cod_comp)
hence 2: "span e e'" using assms(1-2) by blast
hence 3: "Fun e = Fun e'"
using assms eq_Fun_iff_incl_joinable by meson
hence "img e = img e'" using assms 1 img_def by auto
moreover have "img e = cod e ∧ img e' = cod e'"
using assms(6-7) retraction_char img_def mkIde_set by simp
ultimately have "par e e'" using 2 by simp
thus "e = e'" using 3 arr_eqI by blast
hence "par m m'" using assms(1) assms(2) 1 by fastforce
thus "m = m'" using assms(4) assms(5) incls_coherent by blast
qed
end
section "Concrete Set Categories"
text‹
The ‹set_category› locale is useful for stating results that depend on a
category of @{typ 'a}-sets and functions, without having to commit to a particular
element type @{typ 'a}. However, in applications we often need to work with a
category of sets and functions that is guaranteed to contain sets corresponding
to the subsets of some extrinsically given type @{typ 'a}.
A \emph{concrete set category} is a set category ‹S› that is equipped
with an injective function @{term ι} from type @{typ 'a} to ‹S.Univ›.
The following locale serves to facilitate some of the technical aspects of passing
back and forth between elements of type @{typ 'a} and the elements of ‹S.Univ›.
›
locale concrete_set_category = set_category S 𝔄
for S :: "'s comp" (infixr "⋅⇩S" 55)
and 𝔄 :: "'t rel"
and U :: "'a set"
and ι :: "'a ⇒ 's" +
assumes ι_mapsto: "ι ∈ U → Univ"
and inj_ι: "inj_on ι U"
begin
abbreviation 𝗈
where "𝗈 ≡ inv_into U ι"
lemma 𝗈_mapsto:
shows "𝗈 ∈ ι ` U → U"
by (simp add: inv_into_into)
lemma 𝗈_ι [simp]:
assumes "x ∈ U"
shows "𝗈 (ι x) = x"
using assms inj_ι inv_into_f_f by simp
lemma ι_𝗈 [simp]:
assumes "t ∈ ι ` U"
shows "ι (𝗈 t) = t"
using assms o_def inj_ι by auto
end
locale replete_concrete_set_category =
replete_set_category S +
concrete_set_category S ‹cardSuc (cmax (card_of (UNIV :: 's set)) natLeq)› U ι
for S :: "'s comp" (infixr "⋅⇩S" 55)
and U :: "'a set"
and ι :: "'a ⇒ 's"
end
Theory SetCat
chapter SetCat
theory SetCat
imports SetCategory ConcreteCategory
begin
text‹
This theory proves the consistency of the ‹set_category› locale by giving
a particular concrete construction of an interpretation for it.
Applying the general construction given by @{locale concrete_category},
we define arrows to be terms ‹MkArr A B F›, where ‹A› and ‹B› are sets
and ‹F› is an extensional function that maps ‹A› to ‹B›.
›
text‹
This locale uses an extra dummy parameter just to fix the element type for sets.
Without this, a type is used for each interpretation, which makes it impossible to
construct set categories whose element types are related to the context.
›
locale setcat =
fixes dummy :: 'e
and 𝔄 :: "'a rel"
assumes cardinal: "Card_order 𝔄 ∧ infinite (Field 𝔄)"
begin
lemma finite_imp_card_less:
assumes "finite A"
shows "|A| <o 𝔄"
proof -
have "finite (Field |A| )"
using assms by simp
thus ?thesis
using cardinal card_of_Well_order card_order_on_def finite_ordLess_infinite
by blast
qed
type_synonym 'b arr = "('b set, 'b ⇒ 'b) concrete_category.arr"
interpretation concrete_category ‹{A :: 'e set. |A| <o 𝔄}› ‹λA B. extensional A ∩ (A → B)›
‹λA. λx ∈ A. x› ‹λC B A g f. compose A g f›
using compose_Id Id_compose
apply unfold_locales
apply auto[3]
apply blast
by (metis IntD2 compose_assoc)
abbreviation comp :: "'e setcat.arr comp" (infixr "⋅" 55)
where "comp ≡ COMP"
notation in_hom ("«_ : _ → _»")
lemma MkArr_expansion:
assumes "arr f"
shows "f = MkArr (Dom f) (Cod f) (λx ∈ Dom f. Map f x)"
proof (intro arr_eqI)
show "arr f" by fact
show "arr (MkArr (Dom f) (Cod f) (λx ∈ Dom f. Map f x))"
using assms arr_char
by (metis (mono_tags, lifting) Int_iff MkArr_Map extensional_restrict)
show "Dom f = Dom (MkArr (Dom f) (Cod f) (λx ∈ Dom f. Map f x))"
by simp
show "Cod f = Cod (MkArr (Dom f) (Cod f) (λx ∈ Dom f. Map f x))"
by simp
show "Map f = Map (MkArr (Dom f) (Cod f) (λx ∈ Dom f. Map f x))"
using assms arr_char
by (metis (mono_tags, lifting) Int_iff MkArr_Map extensional_restrict)
qed
lemma arr_char:
shows "arr f ⟷ f ≠ Null ∧ |Dom f| <o 𝔄 ∧ |Cod f| <o 𝔄 ∧
Map f ∈ extensional (Dom f) ∩ (Dom f → Cod f)"
using arr_char by auto
lemma terminal_char:
shows "terminal a ⟷ (∃x. a = MkIde {x})"
proof
show "∃x. a = MkIde {x} ⟹ terminal a"
proof -
assume a: "∃x. a = MkIde {x}"
from this obtain x where x: "a = MkIde {x}" by blast
have "terminal (MkIde {x})"
proof
show 1: "ide (MkIde {x})"
using finite_imp_card_less ide_MkIde by auto
show "⋀a. ide a ⟹ ∃!f. «f : a → MkIde {x}»"
proof
fix a :: "'e setcat.arr"
assume a: "ide a"
show "«MkArr (Dom a) {x} (λ_∈Dom a. x) : a → MkIde {x}»"
proof
show 2: "arr (MkArr (Dom a) {x} (λ_ ∈ Dom a. x))"
using a 1 arr_MkArr [of "Dom a" "{x}"] ide_char by force
show "dom (MkArr (Dom a) {x} (λ_ ∈ Dom a. x)) = a"
using a 2 dom_MkArr by force
show "cod (MkArr (Dom a) {x} (λ_∈Dom a. x)) = MkIde {x}"
using 2 cod_MkArr by blast
qed
fix f :: "'e setcat.arr"
assume f: "«f : a → MkIde {x}»"
show "f = MkArr (Dom a) {x} (λ_ ∈ Dom a. x)"
proof -
have 1: "Dom f = Dom a ∧ Cod f = {x}"
using a f by (metis (mono_tags, lifting) Dom.simps(1) in_hom_char)
moreover have "Map f = (λ_ ∈ Dom a. x)"
proof
fix z
have "z ∉ Dom a ⟹ Map f z = (λ_ ∈ Dom a. x) z"
using f 1 MkArr_expansion
by (metis (mono_tags, lifting) Map.simps(1) in_homE restrict_apply)
moreover have "z ∈ Dom a ⟹ Map f z = (λ_ ∈ Dom a. x) z"
using f 1 arr_char [of f] by fastforce
ultimately show "Map f z = (λ_ ∈ Dom a. x) z" by auto
qed
ultimately show ?thesis
using f MkArr_expansion [of f] by fastforce
qed
qed
qed
thus "terminal a" using x by simp
qed
show "terminal a ⟹ ∃x. a = MkIde {x}"
proof -
assume a: "terminal a"
hence ide_a: "ide a" using terminal_def by auto
have 1: "∃!x. x ∈ Dom a"
proof -
have "Dom a = {} ⟹ ¬terminal a"
proof -
assume "Dom a = {}"
hence 1: "a = MkIde {}"
using MkIde_Dom' ‹ide a› by fastforce
have "⋀f. f ∈ hom (MkIde {undefined}) (MkIde ({} :: 'e set))
⟹ Map f ∈ {undefined} → {}"
proof -
fix f
assume f: "f ∈ hom (MkIde {undefined}) (MkIde ({} :: 'e set))"
show "Map f ∈ {undefined} → {}"
using f MkArr_expansion arr_char [of f] in_hom_char by auto
qed
hence "hom (MkIde {undefined}) a = {}" using 1 by auto
moreover have "ide (MkIde {undefined})"
using finite_imp_card_less
by (metis (mono_tags, lifting) finite.intros(1-2) ide_MkIde mem_Collect_eq)
ultimately show "¬terminal a" by blast
qed
moreover have "⋀x x'. x ∈ Dom a ∧ x' ∈ Dom a ∧ x ≠ x' ⟹ ¬terminal a"
proof -
fix x x'
assume 1: "x ∈ Dom a ∧ x' ∈ Dom a ∧ x ≠ x'"
let ?f = "MkArr {undefined} (Dom a) (λ_ ∈ {undefined}. x)"
let ?f' = "MkArr {undefined} (Dom a) (λ_ ∈ {undefined}. x')"
have "«?f : MkIde {undefined} → a»"
proof
show 2: "arr ?f"
proof (intro arr_MkArr)
show "{undefined} ∈ {A. |A| <o 𝔄}"
by (simp add: finite_imp_card_less)
show "Dom a ∈ {A. |A| <o 𝔄}"
using ide_a ide_char by blast
show "(λ_ ∈ {undefined}. x) ∈ extensional {undefined} ∩ ({undefined} → Dom a)"
using 1 by blast
qed
show "dom ?f = MkIde {undefined}"
using 2 dom_MkArr by auto
show "cod ?f = a"
using 2 cod_MkArr ide_a by force
qed
moreover have "«?f' : MkIde {undefined} → a»"
proof
show 2: "arr ?f'"
using 1 ide_a ide_char arr_MkArr [of "{undefined}" "Dom a"]
finite_imp_card_less
proof (intro arr_MkArr)
show "{undefined} ∈ {A. |A| <o 𝔄}"
by (simp add: finite_imp_card_less)
show "Dom a ∈ {A. |A| <o 𝔄}"
using ide_a ide_char by blast
show "(λ_ ∈ {undefined}. x') ∈ extensional {undefined} ∩ ({undefined} → Dom a)"
using 1 by blast
qed
show "dom ?f' = MkIde {undefined}"
using 2 dom_MkArr by auto
show "cod ?f' = a"
using 2 cod_MkArr ide_a by force
qed
moreover have "?f ≠ ?f'"
using 1 by (metis arr.inject restrict_apply' singletonI)
ultimately show "¬terminal a"
using terminal_arr_unique
by (metis (mono_tags, lifting) in_homE)
qed
ultimately show ?thesis
using a by auto
qed
hence "Dom a = {THE x. x ∈ Dom a}"
using theI [of "λx. x ∈ Dom a"] by auto
hence "a = MkIde {THE x. x ∈ Dom a}"
using a terminal_def by (metis (mono_tags, lifting) MkIde_Dom')
thus "∃x. a = MkIde {x}"
by auto
qed
qed
definition IMG :: "'e setcat.arr ⇒ 'e setcat.arr"
where "IMG f = MkIde (Map f ` Dom f)"
interpretation set_category_data comp IMG ..
lemma terminal_unity:
shows "terminal unity"
using terminal_char unity_def someI_ex [of terminal]
by (metis (mono_tags, lifting))
text‹
The inverse maps @{term UP} and @{term DOWN} are used to pass back and forth between
the inhabitants of type @{typ 'a} and the corresponding terminal objects.
These are exported so that a client of the theory can relate the concrete
element type @{typ 'a} to the otherwise abstract arrow type.
›
definition UP :: "'e ⇒ 'e setcat.arr"
where "UP x ≡ MkIde {x}"
definition DOWN :: "'e setcat.arr ⇒ 'e"
where "DOWN t ≡ the_elem (Dom t)"
abbreviation U
where "U ≡ DOWN unity"
lemma UP_mapsto:
shows "UP ∈ UNIV → Univ"
using terminal_char UP_def by fast
lemma DOWN_mapsto:
shows "DOWN ∈ Univ → UNIV"
by auto
lemma DOWN_UP [simp]:
shows "DOWN (UP x) = x"
by (simp add: DOWN_def UP_def)
lemma UP_DOWN [simp]:
assumes "t ∈ Univ"
shows "UP (DOWN t) = t"
using assms terminal_char UP_def DOWN_def
by (metis (mono_tags, lifting) mem_Collect_eq DOWN_UP)
lemma inj_UP:
shows "inj UP"
by (metis DOWN_UP injI)
lemma bij_UP:
shows "bij_betw UP UNIV Univ"
proof (intro bij_betwI)
interpret category comp using is_category by auto
show DOWN_UP: "⋀x :: 'e. DOWN (UP x) = x" by simp
show UP_DOWN: "⋀t. t ∈ Univ ⟹ UP (DOWN t) = t" by simp
show "UP ∈ UNIV → Univ" using UP_mapsto by auto
show "DOWN ∈ Collect terminal → UNIV" by auto
qed
lemma Dom_terminal:
assumes "terminal t"
shows "Dom t = {DOWN t}"
using assms UP_def
by (metis (mono_tags, lifting) Dom.simps(1) DOWN_def terminal_char the_elem_eq)
text‹
The image of a point @{term "p ∈ hom unity a"} is a terminal object, which is given
by the formula @{term "(UP o Fun p o DOWN) unity"}.
›
lemma IMG_point:
assumes "«p : unity → a»"
shows "IMG ∈ hom unity a → Univ"
and "IMG p = (UP o Map p o DOWN) unity"
proof -
show "IMG ∈ hom unity a → Univ"
proof
fix f
assume f: "f ∈ hom unity a"
have "terminal (MkIde (Map f ` Dom unity))"
proof -
obtain u :: 'e where u: "unity = MkIde {u}"
using terminal_unity terminal_char
by (metis (mono_tags, lifting))
have "Map f ` Dom unity = {Map f u}"
using u by simp
thus ?thesis
using terminal_char by auto
qed
hence "MkIde (Map f ` Dom unity) ∈ Univ" by simp
moreover have "MkIde (Map f ` Dom unity) = IMG f"
using f IMG_def in_hom_char
by (metis (mono_tags, lifting) mem_Collect_eq)
ultimately show "IMG f ∈ Univ" by auto
qed
have "IMG p = MkIde (Map p ` Dom p)" using IMG_def by blast
also have "... = MkIde (Map p ` {U})"
using assms in_hom_char terminal_unity Dom_terminal
by (metis (mono_tags, lifting))
also have "... = (UP o Map p o DOWN) unity" by (simp add: UP_def)
finally show "IMG p = (UP o Map p o DOWN) unity" using assms by auto
qed
text‹
The function @{term IMG} is injective on @{term "hom unity a"} and its inverse takes
a terminal object @{term t} to the arrow in @{term "hom unity a"} corresponding to the
constant-@{term t} function.
›
abbreviation MkElem :: "'e setcat.arr => 'e setcat.arr => 'e setcat.arr"
where "MkElem t a ≡ MkArr {U} (Dom a) (λ_ ∈ {U}. DOWN t)"
lemma MkElem_in_hom:
assumes "arr f" and "x ∈ Dom f"
shows "«MkElem (UP x) (dom f) : unity → dom f»"
proof -
have "(λ_ ∈ {U}. DOWN (UP x)) ∈ {U} → Dom (dom f)"
using assms dom_char [of f] by simp
moreover have "MkIde {U} = unity"
using terminal_char terminal_unity
by (metis (mono_tags, lifting) DOWN_UP UP_def)
moreover have "MkIde (Dom (dom f)) = dom f"
using assms dom_char MkIde_Dom' ide_dom by blast
ultimately show ?thesis
using assms MkArr_in_hom [of "{U}" "Dom (dom f)" "λ_ ∈ {U}. DOWN (UP x)"]
by (metis (no_types, lifting) Dom.simps(1) Dom_in_Obj IntI arr_dom ideD(1)
restrict_extensional terminal_def terminal_unity)
qed
lemma MkElem_IMG:
assumes "p ∈ hom unity a"
shows "MkElem (IMG p) a = p"
proof -
have 0: "IMG p = UP (Map p U)"
using assms IMG_point(2) by auto
have 1: "Dom p = {U}"
using assms terminal_unity Dom_terminal
by (metis (mono_tags, lifting) in_hom_char mem_Collect_eq)
moreover have "Cod p = Dom a"
using assms
by (metis (mono_tags, lifting) in_hom_char mem_Collect_eq)
moreover have "Map p = (λ_ ∈ {U}. DOWN (IMG p))"
proof
fix e
show "Map p e = (λ_ ∈ {U}. DOWN (IMG p)) e"
proof -
have "Map p e = (λx ∈ Dom p. Map p x) e"
using assms MkArr_expansion [of p]
by (metis (mono_tags, lifting) CollectD Map.simps(1) in_homE)
also have "... = (λ_ ∈ {U}. DOWN (IMG p)) e"
using assms 0 1 by simp
finally show ?thesis by blast
qed
qed
ultimately show "MkElem (IMG p) a = p"
using assms MkArr_Map CollectD
by (metis (mono_tags, lifting) in_homE mem_Collect_eq)
qed
lemma inj_IMG:
assumes "ide a"
shows "inj_on IMG (hom unity a)"
proof (intro inj_onI)
fix x y
assume x: "x ∈ hom unity a"
assume y: "y ∈ hom unity a"
assume eq: "IMG x = IMG y"
show "x = y"
proof (intro arr_eqI)
show "arr x" using x by blast
show "arr y" using y by blast
show "Dom x = Dom y"
using x y in_hom_char by (metis (mono_tags, lifting) CollectD)
show "Cod x = Cod y"
using x y in_hom_char by (metis (mono_tags, lifting) CollectD)
show "Map x = Map y"
proof -
have "⋀a. y ∈ hom unity a ⟹ MkArr {U} (Dom a) (λe∈{U}. DOWN (IMG x)) = y"
using MkElem_IMG eq by presburger
hence "y = x"
using MkElem_IMG x y by blast
thus ?thesis by meson
qed
qed
qed
lemma set_char:
assumes "ide a"
shows "set a = UP ` Dom a"
proof
show "set a ⊆ UP ` Dom a"
proof
fix t
assume "t ∈ set a"
from this obtain p where p: "«p : unity → a» ∧ t = IMG p"
using set_def by blast
have "t = (UP o Map p o DOWN) unity"
using p IMG_point(2) by blast
moreover have "(Map p o DOWN) unity ∈ Dom a"
using p arr_char in_hom_char Dom_terminal terminal_unity
by (metis (mono_tags, lifting) IntD2 Pi_split_insert_domain o_apply)
ultimately show "t ∈ UP ` Dom a" by simp
qed
show "UP ` Dom a ⊆ set a"
proof
fix t
assume "t ∈ UP ` Dom a"
from this obtain x where x: "x ∈ Dom a ∧ t = UP x" by blast
let ?p = "MkElem (UP x) a"
have p: "?p ∈ hom unity a"
using assms x MkElem_in_hom [of "dom a"] ideD(1-2) by force
moreover have "IMG ?p = t"
using p x DOWN_UP IMG_def UP_def
by (metis (no_types, lifting) Dom.simps(1) Map.simps(1) image_empty
image_insert image_restrict_eq)
ultimately show "t ∈ set a" using set_def by blast
qed
qed
lemma Map_via_comp:
assumes "arr f"
shows "Map f = (λx ∈ Dom f. Map (f ⋅ MkElem (UP x) (dom f)) U)"
proof
fix x
have "x ∉ Dom f ⟹ Map f x = (λx ∈ Dom f. Map (f ⋅ MkElem (UP x) (dom f)) U) x"
using assms arr_char [of f] IntD1 extensional_arb restrict_apply by fastforce
moreover have
"x ∈ Dom f ⟹ Map f x = (λx ∈ Dom f. Map (f ⋅ MkElem (UP x) (dom f)) U) x"
proof -
assume x: "x ∈ Dom f"
let ?X = "MkElem (UP x) (dom f)"
have "«?X : unity → dom f»"
using assms x MkElem_in_hom by auto
moreover have "Dom ?X = {U} ∧ Map ?X = (λ_ ∈ {U}. x)"
using x by simp
ultimately have
"Map (f ⋅ MkElem (UP x) (dom f)) = compose {U} (Map f) (λ_ ∈ {U}. x)"
using assms x Map_comp [of "MkElem (UP x) (dom f)" f]
by (metis (mono_tags, lifting) Cod.simps(1) Dom_dom arr_iff_in_hom seqE seqI')
thus ?thesis
using x by (simp add: compose_eq restrict_apply' singletonI)
qed
ultimately show "Map f x = (λx ∈ Dom f. Map (f ⋅ MkElem (UP x) (dom f)) U) x"
by auto
qed
lemma arr_eqI':
assumes "par f f'" and "⋀t. «t : unity → dom f» ⟹ f ⋅ t = f' ⋅ t"
shows "f = f'"
proof (intro arr_eqI)
show "arr f" using assms by simp
show "arr f'" using assms by simp
show "Dom f = Dom f'"
using assms by (metis (mono_tags, lifting) Dom_dom)
show "Cod f = Cod f'"
using assms by (metis (mono_tags, lifting) Cod_cod)
show "Map f = Map f'"
proof
have 1: "⋀x. x ∈ Dom f ⟹ «MkElem (UP x) (dom f) : unity → dom f»"
using MkElem_in_hom by (metis (mono_tags, lifting) assms(1))
fix x
show "Map f x = Map f' x"
using assms 1 ‹Dom f = Dom f'› by (simp add: Map_via_comp)
qed
qed
text ‹
We need to show that the cardinality constraint on the sets that determine objects
implies a corresponding constraint on the sets of global elements of those objects.
›
lemma card_points_less:
assumes "ide a"
shows "|hom unity a| <o 𝔄"
proof -
have "bij_betw (λf. Map f U) (hom unity a) (Dom a)"
proof (intro bij_betwI')
show "⋀x. x ∈ hom unity a ⟹ Map x (DOWN unity) ∈ Dom a"
using arr_char Dom_terminal terminal_unity in_hom_char by auto
show "⋀x y. ⟦x ∈ hom unity a; y ∈ hom unity a⟧ ⟹ Map x U = Map y U ⟷ x = y"
proof -
fix x y
assume x: "x ∈ hom unity a" and y: "y ∈ hom unity a"
have 1: "Map x ∈ extensional {U} ∧ Map y ∈ extensional {U}"
using x y in_hom_char Dom_terminal terminal_unity
by (metis (mono_tags, lifting) Map_via_comp mem_Collect_eq restrict_extensional)
show "Map x U = Map y U ⟷ x = y"
proof
show "x = y ⟹ Map x U = Map y U"
by simp
show "Map x U = Map y U ⟹ x = y"
proof -
assume 2: "Map x U = Map y U"
have "Map x = Map y"
proof
fix z
show "Map x z = Map y z"
using 1 2 extensional_arb [of "Map x"] extensional_arb [of "Map y"]
by (cases "z = U") auto
qed
thus "x = y"
using x y 1 in_hom_char
by (intro arr_eqI) auto
qed
qed
qed
show "⋀y. y ∈ Dom a ⟹ ∃x ∈ hom unity a. y = Map x (DOWN unity)"
proof -
fix y
assume y: "y ∈ Dom a"
let ?x = "MkArr {DOWN unity} (Dom a) (λ_ ∈ {U}. y)"
have "arr ?x"
proof (intro arr_MkArr)
show "{U} ∈ {A. |A| <o 𝔄}"
by (metis (mono_tags, lifting) Dom_terminal ide_char terminal_def terminal_unity)
show "Dom a ∈ {A. |A| <o 𝔄}"
using assms ide_char by blast
show "(λ_ ∈ {U}. y) ∈ extensional {U} ∩ ({U} → Dom a)"
using assms y by blast
qed
hence "?x ∈ hom unity a"
using UP_DOWN UP_def assms cod_MkArr dom_char in_homI terminal_unity by simp
moreover have "y = Map ?x (DOWN unity)"
by simp
ultimately show "∃x ∈ hom unity a. y = Map x (DOWN unity)"
by auto
qed
qed
hence "|hom unity a| =o |Dom a|"
using card_of_ordIsoI by auto
moreover have "|Dom a| <o 𝔄"
using assms ide_char by auto
ultimately show "|hom unity a| <o 𝔄"
using ordIso_ordLess_trans by auto
qed
text‹
The main result, which establishes the consistency of the ‹set_category› locale
and provides us with a way of obtaining ``set categories'' at arbitrary types.
›
theorem is_set_category:
shows "set_category comp 𝔄"
proof
show "∃img :: 'e setcat.arr ⇒ 'e setcat.arr. set_category_given_img comp img 𝔄"
proof
show "set_category_given_img (comp :: 'e setcat.arr comp) IMG 𝔄"
proof
show "Card_order 𝔄 ∧ infinite (Field 𝔄 )"
using cardinal by simp
show "Univ ≠ {}" using terminal_char by blast
fix a :: "'e setcat.arr"
assume a: "ide a"
show "IMG ∈ hom unity a → Univ" using IMG_point terminal_unity by blast
show "|hom unity a| <o 𝔄" using a card_points_less by simp
show "inj_on IMG (hom unity a)" using a inj_IMG terminal_unity by blast
next
fix t :: "'e setcat.arr"
assume t: "terminal t"
show "t ∈ IMG ` hom unity t"
proof -
have "t ∈ set t"
using t set_char [of t]
by (metis (mono_tags, lifting) Dom.simps(1) image_insert insertI1 UP_def
terminal_char terminal_def)
thus ?thesis
using t set_def [of t] by simp
qed
next
fix A :: "'e setcat.arr set"
assume A: "A ⊆ Univ" and 0: "|A| <o 𝔄"
show "∃a. ide a ∧ set a = A"
proof
let ?a = "MkArr (DOWN ` A) (DOWN ` A) (λx ∈ (DOWN ` A). x)"
show "ide ?a ∧ set ?a = A"
proof
have "|DOWN ` A| <o 𝔄"
using 0 card_of_image ordLeq_ordLess_trans by blast
thus 1: "ide ?a"
using ide_char [of ?a] by simp
show "set ?a = A"
proof -
have 2: "⋀x. x ∈ A ⟹ x = UP (DOWN x)"
using A UP_DOWN by force
hence "UP ` DOWN ` A = A"
using A UP_DOWN by auto
thus ?thesis
using 1 A set_char [of ?a] by simp
qed
qed
qed
next
fix a b :: "'e setcat.arr"
assume a: "ide a" and b: "ide b" and ab: "set a = set b"
show "a = b"
using a b ab set_char inj_UP inj_image_eq_iff dom_char in_homE ide_in_hom
by (metis (mono_tags, lifting))
next
fix f f' :: "'e setcat.arr"
assume par: "par f f'" and ff': "⋀x. «x : unity → dom f» ⟹ f ⋅ x = f' ⋅ x"
show "f = f'" using par ff' arr_eqI' by blast
next
fix a b :: "'e setcat.arr" and F :: "'e setcat.arr ⇒ 'e setcat.arr"
assume a: "ide a" and b: "ide b" and F: "F ∈ hom unity a → hom unity b"
show "∃f. «f : a → b» ∧ (∀x. «x : unity → dom f» ⟶ f ⋅ x = F x)"
proof
let ?f = "MkArr (Dom a) (Dom b) (λx ∈ Dom a. Map (F (MkElem (UP x) a)) U)"
have 1: "«?f : a → b»"
proof -
have "(λx ∈ Dom a. Map (F (MkElem (UP x) a)) U)
∈ extensional (Dom a) ∩ (Dom a → Dom b)"
proof
show "(λx ∈ Dom a. Map (F (MkElem (UP x) a)) U) ∈ extensional (Dom a)"
using a F by simp
show "(λx ∈ Dom a. Map (F (MkElem (UP x) a)) U) ∈ Dom a → Dom b"
proof
fix x
assume x: "x ∈ Dom a"
have "MkElem (UP x) a ∈ hom unity a"
using x a MkElem_in_hom [of a x] ide_char ideD(1-2) by force
hence 1: "F (MkElem (UP x) a) ∈ hom unity b"
using F by auto
moreover have "Dom (F (MkElem (UP x) a)) = {U}"
using 1 MkElem_IMG
by (metis (mono_tags, lifting) Dom.simps(1))
moreover have "Cod (F (MkElem (UP x) a)) = Dom b"
using 1 by (metis (mono_tags, lifting) CollectD in_hom_char)
ultimately have "Map (F (MkElem (UP x) a)) ∈ {U} → Dom b"
using arr_char [of "F (MkElem (UP x) a)"] by blast
thus "Map (F (MkElem (UP x) a)) U ∈ Dom b" by blast
qed
qed
hence "«?f : MkIde (Dom a) → MkIde (Dom b)»"
using a b MkArr_in_hom ide_char by blast
thus ?thesis
using a b by simp
qed
moreover have "⋀x. «x : unity → dom ?f» ⟹ ?f ⋅ x = F x"
proof -
fix x
assume x: "«x : unity → dom ?f»"
have 2: "x = MkElem (IMG x) a"
using a x 1 MkElem_IMG [of x a]
by (metis (mono_tags, lifting) in_homE mem_Collect_eq)
moreover have 5: "Dom x = {U} ∧ Cod x = Dom a ∧
Map x = (λ_ ∈ {U}. DOWN (IMG x))"
using x 2
by (metis (no_types, lifting) Cod.simps(1) Dom.simps(1) Map.simps(1))
moreover have "Cod ?f = Dom b" using 1 by simp
ultimately have
3: "?f ⋅ x =
MkArr {U} (Dom b) (compose {U} (Map ?f) (λ_ ∈ {U}. DOWN (IMG x)))"
using 1 x comp_char [of ?f "MkElem (IMG x) a"]
by (metis (mono_tags, lifting) in_homE seqI)
have 4: "compose {U} (Map ?f) (λ_ ∈ {U}. DOWN (IMG x)) = Map (F x)"
proof
fix y
have "y ∉ {U} ⟹
compose {U} (Map ?f) (λ_ ∈ {U}. DOWN (IMG x)) y = Map (F x) y"
proof -
assume y: "y ∉ {U}"
have "compose {U} (Map ?f) (λ_ ∈ {U}. DOWN (IMG x)) y = undefined"
using y compose_def extensional_arb by simp
also have "... = Map (F x) y"
proof -
have 5: "F x ∈ hom unity b" using x F 1 by fastforce
hence "Dom (F x) = {U}"
by (metis (mono_tags, lifting) "2" CollectD Dom.simps(1) in_hom_char x)
thus ?thesis
using x y F 5 arr_char [of "F x"] extensional_arb [of "Map (F x)" "{U}" y]
by (metis (mono_tags, lifting) CollectD Int_iff in_hom_char)
qed
ultimately show ?thesis by auto
qed
moreover have
"y ∈ {U} ⟹
compose {U} (Map ?f) (λ_ ∈ {U}. DOWN (IMG x)) y = Map (F x) y"
proof -
assume y: "y ∈ {U}"
have "compose {U} (Map ?f) (λ_ ∈ {U}. DOWN (IMG x)) y =
Map ?f (DOWN (IMG x))"
using y by (simp add: compose_eq restrict_apply')
also have "... = (λx. Map (F (MkElem (UP x) a)) U) (DOWN (IMG x))"
proof -
have "DOWN (IMG x) ∈ Dom a"
using x y a 5 arr_char in_homE restrict_apply by force
thus ?thesis
using restrict_apply by simp
qed
also have "... = Map (F x) y"
using x y 1 2 MkElem_IMG [of x a] by simp
finally show
"compose {U} (Map ?f) (λ_ ∈ {U}. DOWN (IMG x)) y = Map (F x) y"
by auto
qed
ultimately show
"compose {U} (Map ?f) (λ_ ∈ {U}. DOWN (IMG x)) y = Map (F x) y"
by auto
qed
show "?f ⋅ x = F x"
proof (intro arr_eqI)
have 5: "?f ⋅ x ∈ hom unity b" using 1 x by blast
have 6: "F x ∈ hom unity b"
using x F 1
by (metis (mono_tags, lifting) PiE in_homE mem_Collect_eq)
show "arr (comp ?f x)" using 5 by blast
show "arr (F x)" using 6 by blast
show "Dom (comp ?f x) = Dom (F x)"
using 5 6 by (metis (mono_tags, lifting) CollectD in_hom_char)
show "Cod (comp ?f x) = Cod (F x)"
using 5 6 by (metis (mono_tags, lifting) CollectD in_hom_char)
show "Map (comp ?f x) = Map (F x)"
using 3 4 by simp
qed
qed
thus "«?f : a → b» ∧ (∀x. «x : unity → dom ?f» ⟶ comp ?f x = F x)"
using 1 by blast
qed
qed
qed
qed
text‹
‹SetCat› can be viewed as a concrete set category over its own element type
@{typ 'a}, using @{term UP} as the required injection from @{typ 'a} to the universe
of ‹SetCat›.
›
corollary is_concrete_set_category:
shows "concrete_set_category comp 𝔄 UNIV UP"
proof -
interpret S: set_category comp 𝔄 using is_set_category by auto
show ?thesis
proof
show 1: "UP ∈ UNIV → S.Univ"
using UP_def terminal_char by force
show "inj_on UP UNIV"
using inj_UP by blast
qed
qed
text‹
As a consequence of the categoricity of the ‹set_category› axioms,
if @{term S} interprets ‹set_category›, and if @{term φ} is a bijection between
the universe of @{term S} and the elements of type @{typ 'a}, then @{term S} is isomorphic
to the category ‹setcat› of @{typ 'a} sets and functions between them constructed here.
›
corollary set_category_iso_SetCat:
fixes S :: "'s comp" and φ :: "'s ⇒ 'e"
assumes "set_category S 𝔄"
and "bij_betw φ (Collect (category.terminal S)) UNIV"
shows "∃Φ. invertible_functor S (comp :: 'e setcat.arr comp) Φ
∧ (∀m. set_category.incl S 𝔄 m ⟶ set_category.incl comp 𝔄 (Φ m))"
proof -
interpret S: set_category S using assms by auto
let ?ψ = "inv_into S.Univ φ"
have "bij_betw (UP o φ) S.Univ (Collect terminal)"
proof (intro bij_betwI)
show "UP o φ ∈ S.Univ → Collect terminal"
using assms(2) UP_mapsto by auto
show "?ψ o DOWN ∈ Collect terminal → S.Univ"
proof
fix x :: "'e setcat.arr"
assume x: "x ∈ Univ"
show "(inv_into S.Univ φ ∘ DOWN) x ∈ S.Univ"
using x assms(2) bij_betw_def comp_apply inv_into_into
by (metis UNIV_I)
qed
fix t
assume "t ∈ S.Univ"
thus "(?ψ o DOWN) ((UP o φ) t) = t"
using assms(2) bij_betw_inv_into_left
by (metis comp_apply DOWN_UP)
next
fix t' :: "'e setcat.arr"
assume "t' ∈ Collect terminal"
thus "(UP o φ) ((?ψ o DOWN) t') = t'"
using assms(2) by (simp add: bij_betw_def f_inv_into_f)
qed
thus ?thesis
using assms(1) set_category_is_categorical [of S 𝔄 comp "UP o φ"] is_set_category
by auto
qed
end
sublocale setcat ⊆ set_category comp 𝔄
using is_set_category by simp
sublocale setcat ⊆ concrete_set_category comp 𝔄 UNIV UP
using is_concrete_set_category by simp
text‹
By using a large enough cardinal, we can effectively eliminate the cardinality constraint
on the sets that determine objects and thereby obtain a set category that is replete.
This is the normal use case, which we want to streamline as much as possible,
so it is useful to introduce a special locale for this purpose.
›
locale replete_setcat =
fixes dummy :: 'e
begin
interpretation SC: setcat dummy
‹cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)›
proof
show "Card_order (cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)) ∧
infinite (Field (cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)))"
by (metis Card_order_cmax Field_natLeq cardSuc_Card_order cardSuc_finite
card_of_Card_order finite_cmax infinite_UNIV_char_0 natLeq_Card_order)
qed
text‹
We don't want to expose the concrete details of the construction used to obtain
the interpretation ‹SC›; instead, we want any facts proved about it to be derived
solely from the assumptions of the @{locale set_category} locales.
So we create another level of definitions here.
›
definition comp
where "comp ≡ SC.comp"
definition UP
where "UP ≡ SC.UP"
definition DOWN
where "DOWN ≡ SC.DOWN"
sublocale set_category comp ‹cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)›
using SC.is_set_category comp_def by simp
sublocale concrete_set_category comp
‹cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)› UNIV UP
using SC.is_concrete_set_category comp_def UP_def by simp
sublocale replete_set_category comp ..
lemma UP_mapsto:
shows "UP ∈ UNIV → Univ"
using SC.UP_mapsto
by (simp add: UP_def comp_def)
lemma DOWN_mapsto:
shows "DOWN ∈ Univ → UNIV"
by auto
lemma DOWN_UP [simp]:
shows "DOWN (UP x) = x"
by (simp add: DOWN_def UP_def)
lemma UP_DOWN [simp]:
assumes "t ∈ Univ"
shows "UP (DOWN t) = t"
using assms DOWN_def UP_def
by (simp add: DOWN_def UP_def comp_def)
lemma inj_UP:
shows "inj UP"
by (metis DOWN_UP injI)
lemma bij_UP:
shows "bij_betw UP UNIV Univ"
by (metis SC.bij_UP UP_def comp_def)
end
end
Theory ProductCategory
chapter ProductCategory
theory ProductCategory
imports Category EpiMonoIso
begin
text‹
This theory defines the product of two categories @{term C1} and @{term C2},
which is the category @{term C} whose arrows are ordered pairs consisting of an
arrow of @{term C1} and an arrow of @{term C2}, with composition defined
componentwise. As the ordered pair ‹(C1.null, C2.null)› is available
to serve as ‹C.null›, we may directly identify the arrows of the product
category @{term C} with ordered pairs, leaving the type of arrows of @{term C}
transparent.
›
locale product_category =
C1: category C1 +
C2: category C2
for C1 :: "'a1 comp" (infixr "⋅⇩1" 55)
and C2 :: "'a2 comp" (infixr "⋅⇩2" 55)
begin
type_synonym ('aa1, 'aa2) arr = "'aa1 * 'aa2"
notation C1.in_hom ("«_ : _ →⇩1 _»")
notation C2.in_hom ("«_ : _ →⇩2 _»")
abbreviation (input) Null :: "('a1, 'a2) arr"
where "Null ≡ (C1.null, C2.null)"
abbreviation (input) Arr :: "('a1, 'a2) arr ⇒ bool"
where "Arr f ≡ C1.arr (fst f) ∧ C2.arr (snd f)"
abbreviation (input) Ide :: "('a1, 'a2) arr ⇒ bool"
where "Ide f ≡ C1.ide (fst f) ∧ C2.ide (snd f)"
abbreviation (input) Dom :: "('a1, 'a2) arr ⇒ ('a1, 'a2) arr"
where "Dom f ≡ (if Arr f then (C1.dom (fst f), C2.dom (snd f)) else Null)"
abbreviation (input) Cod :: "('a1, 'a2) arr ⇒ ('a1, 'a2) arr"
where "Cod f ≡ (if Arr f then (C1.cod (fst f), C2.cod (snd f)) else Null)"
definition comp :: "('a1, 'a2) arr ⇒ ('a1, 'a2) arr ⇒ ('a1, 'a2) arr"
where "comp g f = (if Arr f ∧ Arr g ∧ Cod f = Dom g then
(C1 (fst g) (fst f), C2 (snd g) (snd f))
else Null)"
notation comp (infixr "⋅" 55)
lemma not_Arr_Null:
shows "¬Arr Null"
by simp
interpretation partial_magma comp
proof
show "∃!n. ∀f. n ⋅ f = n ∧ f ⋅ n = n"
proof
let ?P = "λn. ∀f. n ⋅ f = n ∧ f ⋅ n = n"
show 1: "?P Null" using comp_def not_Arr_Null by metis
thus "⋀n. ∀f. n ⋅ f = n ∧ f ⋅ n = n ⟹ n = Null" by metis
qed
qed
notation in_hom ("«_ : _ → _»")
lemma null_char [simp]:
shows "null = Null"
proof -
let ?P = "λn. ∀f. n ⋅ f = n ∧ f ⋅ n = n"
have "?P Null" using comp_def not_Arr_Null by metis
thus ?thesis
unfolding null_def using the1_equality [of ?P Null] ex_un_null by blast
qed
lemma ide_Ide:
assumes "Ide a"
shows "ide a"
unfolding ide_def comp_def null_char
using assms C1.not_arr_null C1.ide_in_hom C1.comp_arr_dom C1.comp_cod_arr
C2.comp_arr_dom C2.comp_cod_arr
by auto
lemma has_domain_char:
shows "domains f ≠ {} ⟷ Arr f"
proof
show "domains f ≠ {} ⟹ Arr f"
unfolding domains_def comp_def null_char by (auto; metis)
assume f: "Arr f"
show "domains f ≠ {}"
proof -
have "ide (Dom f) ∧ comp f (Dom f) ≠ null"
using f comp_def ide_Ide C1.comp_arr_dom C1.arr_dom_iff_arr C2.arr_dom_iff_arr
by auto
thus ?thesis using domains_def by blast
qed
qed
lemma has_codomain_char:
shows "codomains f ≠ {} ⟷ Arr f"
proof
show "codomains f ≠ {} ⟹ Arr f"
unfolding codomains_def comp_def null_char by (auto; metis)
assume f: "Arr f"
show "codomains f ≠ {}"
proof -
have "ide (Cod f) ∧ comp (Cod f) f ≠ null"
using f comp_def ide_Ide C1.comp_cod_arr C1.arr_cod_iff_arr C2.arr_cod_iff_arr
by auto
thus ?thesis using codomains_def by blast
qed
qed
lemma arr_char [iff]:
shows "arr f ⟷ Arr f"
using has_domain_char has_codomain_char arr_def by simp
lemma arrI [intro]:
assumes "C1.arr f1" and "C2.arr f2"
shows "arr (f1, f2)"
using assms by simp
lemma arrE:
assumes "arr f"
and "C1.arr (fst f) ∧ C2.arr (snd f) ⟹ T"
shows "T"
using assms by auto
lemma seqI [intro]:
assumes "C1.seq g1 f1 ∧ C2.seq g2 f2"
shows "seq (g1, g2) (f1, f2)"
using assms comp_def by auto
lemma seqE [elim]:
assumes "seq g f"
and "C1.seq (fst g) (fst f) ⟹ C2.seq (snd g) (snd f) ⟹ T"
shows "T"
using assms comp_def
by (metis (no_types, lifting) C1.seqI C2.seqI Pair_inject not_arr_null null_char)
lemma seq_char [iff]:
shows "seq g f ⟷ C1.seq (fst g) (fst f) ∧ C2.seq (snd g) (snd f)"
using comp_def by auto
lemma Dom_comp:
assumes "seq g f"
shows "Dom (g ⋅ f) = Dom f"
proof -
have "C1.arr (fst f) ∧ C1.arr (fst g) ∧ C1.dom (fst g) = C1.cod (fst f)"
using assms by blast
moreover have "C2.arr (snd f) ∧ C2.arr (snd g) ∧ C2.dom (snd g) = C2.cod (snd f)"
using assms by blast
ultimately show ?thesis
by (simp add: comp_def)
qed
lemma Cod_comp:
assumes "seq g f"
shows "Cod (g ⋅ f) = Cod g"
proof -
have "C1.arr (fst f) ∧ C1.arr (fst g) ∧ C1.dom (fst g) = C1.cod (fst f)"
using assms by blast
moreover have "C2.arr (snd f) ∧ C2.arr (snd g) ∧ C2.dom (snd g) = C2.cod (snd f)"
using assms by blast
ultimately show ?thesis
by (simp add: comp_def)
qed
theorem is_category:
shows "category comp"
proof
fix f
show "(domains f ≠ {}) = (codomains f ≠ {})"
using has_domain_char has_codomain_char by simp
fix g
show "g ⋅ f ≠ null ⟹ seq g f"
using comp_def seq_char by (metis C1.seqI C2.seqI Pair_inject null_char)
fix h
show "seq h g ⟹ seq (h ⋅ g) f ⟹ seq g f"
using seq_char
by (metis category.seqE category.seqI Dom_comp
product_category_axioms product_category_def fst_conv snd_conv)
show "seq h (g ⋅ f) ⟹ seq g f ⟹ seq h g"
using seq_char
by (metis category.seqE category.seqI Cod_comp
product_category_axioms product_category_def fst_conv snd_conv)
show "seq g f ⟹ seq h g ⟹ seq (h ⋅ g) f"
using seq_char
by (metis arrE category.seqE category.seqI Dom_comp
product_category_axioms product_category_def fst_conv snd_conv)
show "seq g f ⟹ seq h g ⟹ (h ⋅ g) ⋅ f = h ⋅ g ⋅ f"
using comp_def null_char seq_char C1.comp_assoc C2.comp_assoc
by (elim seqE C1.seqE C2.seqE, simp)
qed
sublocale category comp
using is_category comp_def by auto
lemma dom_char:
shows "dom f = Dom f"
proof (cases "Arr f")
show "¬Arr f ⟹ dom f = Dom f"
unfolding dom_def using has_domain_char by auto
show "Arr f ⟹ dom f = Dom f"
using ide_Ide apply (intro dom_eqI, simp)
using seq_char comp_def C1.arr_dom_iff_arr C2.arr_dom_iff_arr by auto
qed
lemma dom_simp [simp]:
assumes "arr f"
shows "dom f = (C1.dom (fst f), C2.dom (snd f))"
using assms dom_char by auto
lemma cod_char:
shows "cod f = Cod f"
proof (cases "Arr f")
show "¬Arr f ⟹ cod f = Cod f"
unfolding cod_def using has_codomain_char by auto
show "Arr f ⟹ cod f = Cod f"
using ide_Ide seqI apply (intro cod_eqI, simp)
using seq_char comp_def C1.arr_cod_iff_arr C2.arr_cod_iff_arr by auto
qed
lemma cod_simp [simp]:
assumes "arr f"
shows "cod f = (C1.cod (fst f), C2.cod (snd f))"
using assms cod_char by auto
lemma in_homI [intro, simp]:
assumes "«fst f: fst a →⇩1 fst b»" and "«snd f: snd a →⇩2 snd b»"
shows "«f: a → b»"
using assms by fastforce
lemma in_homE [elim]:
assumes "«f: a → b»"
and "«fst f: fst a →⇩1 fst b» ⟹ «snd f: snd a →⇩2 snd b» ⟹ T"
shows "T"
using assms
by (metis C1.in_homI C2.in_homI arr_char cod_simp dom_simp fst_conv in_homE snd_conv)
lemma ide_char [iff]:
shows "ide f ⟷ Ide f"
using ide_in_hom C1.ide_in_hom C2.ide_in_hom by blast
lemma comp_char:
shows "g ⋅ f = (if C1.arr (C1 (fst g) (fst f)) ∧ C2.arr (C2 (snd g) (snd f)) then
(C1 (fst g) (fst f), C2 (snd g) (snd f))
else Null)"
using comp_def by auto
lemma comp_simp [simp]:
assumes "C1.seq (fst g) (fst f)" and "C2.seq (snd g) (snd f)"
shows "g ⋅ f = (fst g ⋅⇩1 fst f, snd g ⋅⇩2 snd f)"
using assms comp_char by simp
lemma iso_char [iff]:
shows "iso f ⟷ C1.iso (fst f) ∧ C2.iso (snd f)"
proof
assume f: "iso f"
obtain g where g: "inverse_arrows f g" using f by auto
have 1: "ide (g ⋅ f) ∧ ide (f ⋅ g)"
using f g by (simp add: inverse_arrows_def)
have "g ⋅ f = (fst g ⋅⇩1 fst f, snd g ⋅⇩2 snd f) ∧ f ⋅ g = (fst f ⋅⇩1 fst g, snd f ⋅⇩2 snd g)"
using 1 comp_char arr_char by (meson ideD(1) seq_char)
hence "C1.ide (fst g ⋅⇩1 fst f) ∧ C2.ide (snd g ⋅⇩2 snd f) ∧
C1.ide (fst f ⋅⇩1 fst g) ∧ C2.ide (snd f ⋅⇩2 snd g)"
using 1 ide_char by simp
hence "C1.inverse_arrows (fst f) (fst g) ∧ C2.inverse_arrows (snd f) (snd g)"
by auto
thus "C1.iso (fst f) ∧ C2.iso (snd f)" by auto
next
assume f: "C1.iso (fst f) ∧ C2.iso (snd f)"
obtain g1 where g1: "C1.inverse_arrows (fst f) g1" using f by blast
obtain g2 where g2: "C2.inverse_arrows (snd f) g2" using f by blast
have "C1.ide (g1 ⋅⇩1 fst f) ∧ C2.ide (g2 ⋅⇩2 snd f) ∧
C1.ide (fst f ⋅⇩1 g1) ∧ C2.ide (snd f ⋅⇩2 g2)"
using g1 g2 ide_char by force
hence "inverse_arrows f (g1, g2)"
using f g1 g2 ide_char comp_char by (intro inverse_arrowsI, auto)
thus "iso f" by auto
qed
lemma isoI [intro, simp]:
assumes "C1.iso (fst f)" and "C2.iso (snd f)"
shows "iso f"
using assms by simp
lemma isoD:
assumes "iso f"
shows "C1.iso (fst f)" and "C2.iso (snd f)"
using assms by auto
lemma inv_simp [simp]:
assumes "iso f"
shows "inv f = (C1.inv (fst f), C2.inv (snd f))"
proof -
have "inverse_arrows f (C1.inv (fst f), C2.inv (snd f))"
proof
have 1: "C1.inverse_arrows (fst f) (C1.inv (fst f))"
using assms iso_char C1.inv_is_inverse by simp
have 2: "C2.inverse_arrows (snd f) (C2.inv (snd f))"
using assms iso_char C2.inv_is_inverse by simp
show "ide ((C1.inv (fst f), C2.inv (snd f)) ⋅ f)"
using 1 2 ide_char comp_char by auto
show "ide (f ⋅ (C1.inv (fst f), C2.inv (snd f)))"
using 1 2 ide_char comp_char by auto
qed
thus ?thesis using inverse_unique by auto
qed
end
end
Theory NaturalTransformation
chapter NaturalTransformation
theory NaturalTransformation
imports Functor
begin
section "Definition of a Natural Transformation"
text‹
As is the case for functors, the ``object-free'' definition of category
makes it possible to view natural transformations as functions on arrows.
In particular, a natural transformation between functors
@{term F} and @{term G} from @{term A} to @{term B} can be represented by
the map that takes each arrow @{term f} of @{term A} to the diagonal of the
square in @{term B} corresponding to the transformation of @{term "F f"}
to @{term "G f"}. The images of the identities of @{term A} under this
map are the usual components of the natural transformation.
This representation exhibits natural transformations as a kind of generalization
of functors, and in fact we can directly identify functors with identity
natural transformations.
However, functors are still necessary to state the defining conditions for
a natural transformation, as the domain and codomain of a natural transformation
cannot be recovered from the map on arrows that represents it.
Like functors, natural transformations preserve arrows and map non-arrows to null.
Natural transformations also ``preserve'' domain and codomain, but in a more general
sense than functors. The naturality conditions, which express the two ways of factoring
the diagonal of a commuting square, are degenerate in the case of an identity transformation.
›
locale natural_transformation =
A: category A +
B: category B +
F: "functor" A B F +
G: "functor" A B G
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and F :: "'a ⇒ 'b"
and G :: "'a ⇒ 'b"
and τ :: "'a ⇒ 'b" +
assumes is_extensional: "¬A.arr f ⟹ τ f = B.null"
and preserves_dom [iff]: "A.arr f ⟹ B.dom (τ f) = F (A.dom f)"
and preserves_cod [iff]: "A.arr f ⟹ B.cod (τ f) = G (A.cod f)"
and is_natural_1 [iff]: "A.arr f ⟹ G f ⋅⇩B τ (A.dom f) = τ f"
and is_natural_2 [iff]: "A.arr f ⟹ τ (A.cod f) ⋅⇩B F f = τ f"
begin
lemma naturality:
assumes "A.arr f"
shows "τ (A.cod f) ⋅⇩B F f = G f ⋅⇩B τ (A.dom f)"
using assms is_natural_1 is_natural_2 by simp
text‹
The following fact for natural transformations provides us with the same advantages
as the corresponding fact for functors.
›
lemma preserves_reflects_arr [iff]:
shows "B.arr (τ f) ⟷ A.arr f"
using is_extensional A.arr_cod_iff_arr B.arr_cod_iff_arr preserves_cod by force
lemma preserves_hom [intro]:
assumes "«f : a →⇩A b»"
shows "«τ f : F a →⇩B G b»"
using assms
by (metis A.in_homE B.arr_cod_iff_arr B.in_homI G.preserves_arr G.preserves_cod
preserves_cod preserves_dom)
lemma preserves_comp_1:
assumes "A.seq f' f"
shows "τ (f' ⋅⇩A f) = G f' ⋅⇩B τ f"
using assms
by (metis A.seqE A.dom_comp B.comp_assoc G.preserves_comp is_natural_1)
lemma preserves_comp_2:
assumes "A.seq f' f"
shows "τ (f' ⋅⇩A f) = τ f' ⋅⇩B F f"
using assms
by (metis A.arr_cod_iff_arr A.cod_comp B.comp_assoc F.preserves_comp is_natural_2)
text‹
A natural transformation that also happens to be a functor is equal to
its own domain and codomain.
›
lemma functor_implies_equals_dom:
assumes "functor A B τ"
shows "F = τ"
proof
interpret τ: "functor" A B τ using assms by auto
fix f
show "F f = τ f"
using assms
by (metis A.dom_cod B.comp_cod_arr F.is_extensional F.preserves_arr F.preserves_cod
τ.preserves_dom is_extensional is_natural_2 preserves_dom)
qed
lemma functor_implies_equals_cod:
assumes "functor A B τ"
shows "G = τ"
proof
interpret τ: "functor" A B τ using assms by auto
fix f
show "G f = τ f"
using assms
by (metis A.cod_dom B.comp_arr_dom F.preserves_arr G.is_extensional G.preserves_arr
G.preserves_dom B.cod_dom functor_implies_equals_dom is_extensional
is_natural_1 preserves_cod preserves_dom)
qed
end
section "Components of a Natural Transformation"
text‹
The values taken by a natural transformation on identities are the \emph{components}
of the transformation. We have the following basic technique for proving two natural
transformations equal: show that they have the same components.
›
lemma eqI:
assumes "natural_transformation A B F G σ" and "natural_transformation A B F G σ'"
and "⋀a. partial_magma.ide A a ⟹ σ a = σ' a"
shows "σ = σ'"
proof -
interpret A: category A using assms(1) natural_transformation_def by blast
interpret σ: natural_transformation A B F G σ using assms(1) by auto
interpret σ': natural_transformation A B F G σ' using assms(2) by auto
have "⋀f. σ f = σ' f"
using assms(3) σ.is_natural_2 σ'.is_natural_2 σ.is_extensional σ'.is_extensional A.ide_cod
by metis
thus ?thesis by auto
qed
text‹
As equality of natural transformations is determined by equality of components,
a natural transformation may be uniquely defined by specifying its components.
The extension to all arrows is given by @{prop is_natural_1} or equivalently
by @{prop is_natural_2}.
›
locale transformation_by_components =
A: category A +
B: category B +
F: "functor" A B F +
G: "functor" A B G
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and F :: "'a ⇒ 'b"
and G :: "'a ⇒ 'b"
and t :: "'a ⇒ 'b" +
assumes maps_ide_in_hom [intro]: "A.ide a ⟹ «t a : F a →⇩B G a»"
and is_natural: "A.arr f ⟹ t (A.cod f) ⋅⇩B F f = G f ⋅⇩B t (A.dom f)"
begin
definition map
where "map f = (if A.arr f then t (A.cod f) ⋅⇩B F f else B.null)"
lemma map_simp_ide [simp]:
assumes "A.ide a"
shows "map a = t a"
using assms map_def B.comp_arr_dom [of "t a"] maps_ide_in_hom by fastforce
lemma is_natural_transformation:
shows "natural_transformation A B F G map"
using map_def is_natural
apply (unfold_locales, simp_all)
apply (metis A.ide_dom B.dom_comp B.seqI
G.preserves_arr G.preserves_dom B.in_homE maps_ide_in_hom)
apply (metis A.ide_dom B.arrI B.cod_comp B.in_homE B.seqI
G.preserves_arr G.preserves_cod G.preserves_dom maps_ide_in_hom)
apply (metis A.ide_dom B.comp_arr_dom B.in_homE maps_ide_in_hom)
by (metis B.comp_assoc A.comp_cod_arr F.preserves_comp)
end
sublocale transformation_by_components ⊆ natural_transformation A B F G map
using is_natural_transformation by auto
lemma transformation_by_components_idem [simp]:
assumes "natural_transformation A B F G τ"
shows "transformation_by_components.map A B F τ = τ"
proof -
interpret τ: natural_transformation A B F G τ using assms by blast
interpret τ': transformation_by_components A B F G τ
by (unfold_locales, auto)
show ?thesis
using assms τ'.map_simp_ide τ'.is_natural_transformation eqI by blast
qed
section "Functors as Natural Transformations"
text‹
A functor is a special case of a natural transformation, in the sense that the same map
that defines the functor also defines an identity natural transformation.
›
lemma functor_is_transformation [simp]:
assumes "functor A B F"
shows "natural_transformation A B F F F"
proof -
interpret "functor" A B F using assms by auto
show "natural_transformation A B F F F"
using is_extensional B.comp_arr_dom B.comp_cod_arr
by (unfold_locales, simp_all)
qed
sublocale "functor" ⊆ natural_transformation A B F F F
by (simp add: functor_axioms)
section "Constant Natural Transformations"
text‹
A constant natural transformation is one whose components are all the same arrow.
›
locale constant_transformation =
A: category A +
B: category B +
F: constant_functor A B "B.dom g" +
G: constant_functor A B "B.cod g"
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and g :: 'b +
assumes value_is_arr: "B.arr g"
begin
definition map
where "map f ≡ if A.arr f then g else B.null"
lemma map_simp [simp]:
assumes "A.arr f"
shows "map f = g"
using assms map_def by auto
lemma is_natural_transformation:
shows "natural_transformation A B F.map G.map map"
apply unfold_locales
using map_def value_is_arr B.comp_arr_dom B.comp_cod_arr by auto
lemma is_functor_if_value_is_ide:
assumes "B.ide g"
shows "functor A B map"
apply unfold_locales using assms map_def by auto
end
sublocale constant_transformation ⊆ natural_transformation A B F.map G.map map
using is_natural_transformation by auto
context constant_transformation
begin
lemma equals_dom_if_value_is_ide:
assumes "B.ide g"
shows "map = F.map"
using assms functor_implies_equals_dom is_functor_if_value_is_ide by auto
lemma equals_cod_if_value_is_ide:
assumes "B.ide g"
shows "map = G.map"
using assms functor_implies_equals_dom is_functor_if_value_is_ide by auto
end
section "Vertical Composition"
text‹
Vertical composition is a way of composing natural transformations ‹σ: F → G›
and ‹τ: G → H›, between parallel functors @{term F}, @{term G}, and @{term H}
to obtain a natural transformation from @{term F} to @{term H}.
The composite is traditionally denoted by ‹τ o σ›, however in the present
setting this notation is misleading because it is horizontal composite, rather than
vertical composite, that coincides with composition of natural transformations as
functions on arrows.
›
locale vertical_composite =
A: category A +
B: category B +
F: "functor" A B F +
G: "functor" A B G +
H: "functor" A B H +
σ: natural_transformation A B F G σ +
τ: natural_transformation A B G H τ
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and F :: "'a ⇒ 'b"
and G :: "'a ⇒ 'b"
and H :: "'a ⇒ 'b"
and σ :: "'a ⇒ 'b"
and τ :: "'a ⇒ 'b"
begin
text‹
Vertical composition takes an arrow @{term "A.in_hom a b f"} to an arrow in
@{term "B.hom (F a) (G b)"}, which we can obtain by forming either of
the composites @{term "B (τ b) (σ f)"} or @{term "B (τ f) (σ a)"}, which are
equal to each other.
›
definition map
where "map f = (if A.arr f then τ (A.cod f) ⋅⇩B σ f else B.null)"
lemma map_seq:
assumes "A.arr f"
shows "B.seq (τ (A.cod f)) (σ f)"
using assms by auto
lemma map_simp_ide:
assumes "A.ide a"
shows "map a = τ a ⋅⇩B σ a"
using assms map_def by auto
lemma map_simp_1:
assumes "A.arr f"
shows "map f = τ (A.cod f) ⋅⇩B σ f"
using assms by (simp add: map_def)
lemma map_simp_2:
assumes "A.arr f"
shows "map f = τ f ⋅⇩B σ (A.dom f)"
using assms
by (metis B.comp_assoc σ.is_natural_2 σ.naturality τ.is_natural_1 τ.naturality map_simp_1)
lemma is_natural_transformation:
shows "natural_transformation A B F H map"
using map_def map_simp_1 map_simp_2 map_seq B.comp_assoc
apply (unfold_locales, simp_all)
by (metis B.comp_assoc τ.is_natural_1)
end
sublocale vertical_composite ⊆ natural_transformation A B F H map
using is_natural_transformation by auto
text‹
Functors are the identities for vertical composition.
›
lemma vcomp_ide_dom [simp]:
assumes "natural_transformation A B F G τ"
shows "vertical_composite.map A B F τ = τ"
using assms apply (intro eqI)
apply auto[2]
apply (meson functor_is_transformation natural_transformation_def vertical_composite.intro
vertical_composite.is_natural_transformation)
proof -
fix a :: 'a
have "vertical_composite A B F F G F τ"
by (meson assms functor_is_transformation natural_transformation.axioms(1-4)
vertical_composite.intro)
thus "vertical_composite.map A B F τ a = τ a"
using assms natural_transformation.is_extensional natural_transformation.is_natural_2
vertical_composite.map_def
by fastforce
qed
lemma vcomp_ide_cod [simp]:
assumes "natural_transformation A B F G τ"
shows "vertical_composite.map A B τ G = τ"
using assms apply (intro eqI)
apply auto[2]
apply (meson functor_is_transformation natural_transformation_def vertical_composite.intro
vertical_composite.is_natural_transformation)
proof -
fix a :: 'a
assume a: "partial_magma.ide A a"
interpret Goτ: vertical_composite A B F G G τ G
by (meson assms functor_is_transformation natural_transformation.axioms(1-4)
vertical_composite.intro)
show "vertical_composite.map A B τ G a = τ a"
using assms a natural_transformation.is_extensional natural_transformation.is_natural_1
Goτ.map_simp_ide Goτ.B.comp_cod_arr
by simp
qed
text‹
Vertical composition is associative.
›
lemma vcomp_assoc [simp]:
assumes "natural_transformation A B F G ρ"
and "natural_transformation A B G H σ"
and "natural_transformation A B H K τ"
shows "vertical_composite.map A B (vertical_composite.map A B ρ σ) τ
= vertical_composite.map A B ρ (vertical_composite.map A B σ τ)"
proof -
interpret A: category A
using assms(1) natural_transformation_def functor_def by blast
interpret B: category B
using assms(1) natural_transformation_def functor_def by blast
interpret ρ: natural_transformation A B F G ρ using assms(1) by auto
interpret σ: natural_transformation A B G H σ using assms(2) by auto
interpret τ: natural_transformation A B H K τ using assms(3) by auto
interpret ρσ: vertical_composite A B F G H ρ σ ..
interpret στ: vertical_composite A B G H K σ τ ..
interpret ρ_στ: vertical_composite A B F G K ρ στ.map ..
interpret ρσ_τ: vertical_composite A B F H K ρσ.map τ ..
show ?thesis
using ρσ_τ.is_natural_transformation ρ_στ.natural_transformation_axioms
ρσ.map_simp_ide ρσ_τ.map_simp_ide ρ_στ.map_simp_ide στ.map_simp_ide B.comp_assoc
by (intro eqI, auto)
qed
section "Natural Isomorphisms"
text‹
A natural isomorphism is a natural transformation each of whose components
is an isomorphism. Equivalently, a natural isomorphism is a natural transformation
that is invertible with respect to vertical composition.
›
locale natural_isomorphism = natural_transformation A B F G τ
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and F :: "'a ⇒ 'b"
and G :: "'a ⇒ 'b"
and τ :: "'a ⇒ 'b" +
assumes components_are_iso [simp]: "A.ide a ⟹ B.iso (τ a)"
begin
lemma inv_naturality:
assumes "A.arr f"
shows "F f ⋅⇩B B.inv (τ (A.dom f)) = B.inv (τ (A.cod f)) ⋅⇩B G f"
using assms is_natural_1 is_natural_2 components_are_iso B.invert_side_of_triangle
B.comp_assoc A.ide_cod A.ide_dom preserves_reflects_arr
by fastforce
text ‹
Natural isomorphisms preserve isomorphisms, in the sense that the sides of
of the naturality square determined by an isomorphism are all isomorphisms,
so the diagonal is, as well.
›
lemma preserves_iso:
assumes "A.iso f"
shows "B.iso (τ f)"
using assms
by (metis A.ide_dom A.iso_is_arr B.isos_compose G.preserves_iso components_are_iso
is_natural_2 naturality preserves_reflects_arr)
end
text ‹
Since the function that represents a functor is formally identical to the function
that represents the corresponding identity natural transformation, no additional locale
is needed for identity natural transformations. However, an identity natural transformation
is also a natural isomorphism, so it is useful for @{locale functor} to inherit from the
@{locale natural_isomorphism} locale.
›
sublocale "functor" ⊆ natural_isomorphism A B F F F
apply unfold_locales
using preserves_ide B.ide_is_iso by simp
definition naturally_isomorphic
where "naturally_isomorphic A B F G = (∃τ. natural_isomorphism A B F G τ)"
lemma naturally_isomorphic_respects_full_functor:
assumes "naturally_isomorphic A B F G"
and "full_functor A B F"
shows "full_functor A B G"
proof -
obtain φ where φ: "natural_isomorphism A B F G φ"
using assms naturally_isomorphic_def by blast
interpret φ: natural_isomorphism A B F G φ
using φ by auto
interpret φ.F: full_functor A B F
using assms by auto
write A (infixr "⋅⇩A" 55)
write B (infixr "⋅⇩B" 55)
write φ.A.in_hom ("«_ : _ →⇩A _»")
write φ.B.in_hom ("«_ : _ →⇩B _»")
show "full_functor A B G"
proof
fix a a' g
assume a': "φ.A.ide a'" and a: "φ.A.ide a"
and g: "«g : G a' →⇩B G a»"
show "∃f. «f : a' →⇩A a» ∧ G f = g"
proof -
let ?g' = "φ.B.inv (φ a) ⋅⇩B g ⋅⇩B φ a'"
have g': "«?g' : F a' →⇩B F a»"
using a a' g φ.preserves_hom φ.components_are_iso φ.B.inv_in_hom by force
obtain f' where f': "«f' : a' →⇩A a» ∧ F f' = ?g'"
using a a' g' φ.F.is_full [of a a' ?g'] by blast
moreover have "G f' = g"
proof -
have "G f' = φ a ⋅⇩B ?g' ⋅⇩B φ.B.inv (φ a')"
using a a' f' φ.naturality [of f'] φ.components_are_iso φ.is_natural_2
by (metis φ.A.in_homE φ.B.comp_assoc φ.B.invert_side_of_triangle(2)
φ.preserves_reflects_arr)
also have "... = (φ a ⋅⇩B φ.B.inv (φ a)) ⋅⇩B g ⋅⇩B φ a' ⋅⇩B φ.B.inv (φ a')"
using φ.B.comp_assoc by auto
also have "... = g"
using a a' g φ.B.comp_arr_dom φ.B.comp_cod_arr φ.B.comp_arr_inv
φ.B.inv_is_inverse
by auto
finally show ?thesis by blast
qed
ultimately show ?thesis by auto
qed
qed
qed
lemma naturally_isomorphic_respects_faithful_functor:
assumes "naturally_isomorphic A B F G"
and "faithful_functor A B F"
shows "faithful_functor A B G"
proof -
obtain φ where φ: "natural_isomorphism A B F G φ"
using assms naturally_isomorphic_def by blast
interpret φ: natural_isomorphism A B F G φ
using φ by auto
interpret φ.F: faithful_functor A B F
using assms by auto
show "faithful_functor A B G"
using φ.naturality φ.components_are_iso φ.B.iso_is_section φ.B.section_is_mono
φ.B.monoE φ.F.is_faithful φ.is_natural_1 φ.natural_transformation_axioms
φ.preserves_reflects_arr φ.A.ide_cod
by (unfold_locales, metis)
qed
locale inverse_transformation =
A: category A +
B: category B +
F: "functor" A B F +
G: "functor" A B G +
τ: natural_isomorphism A B F G τ
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and F :: "'a ⇒ 'b"
and G :: "'a ⇒ 'b"
and τ :: "'a ⇒ 'b"
begin
interpretation τ': transformation_by_components A B G F ‹λa. B.inv (τ a)›
proof
fix f :: 'a
show "A.ide f ⟹ «B.inv (τ f) : G f →⇩B F f»"
using B.inv_in_hom τ.components_are_iso A.ide_in_hom by blast
show "A.arr f ⟹ B.inv (τ (A.cod f)) ⋅⇩B G f = F f ⋅⇩B B.inv (τ (A.dom f))"
by (metis A.ide_cod A.ide_dom B.invert_opposite_sides_of_square τ.components_are_iso
τ.is_natural_2 τ.naturality τ.preserves_reflects_arr)
qed
definition map
where "map = τ'.map"
lemma map_ide_simp [simp]:
assumes "A.ide a"
shows "map a = B.inv (τ a)"
using assms map_def by fastforce
lemma map_simp:
assumes "A.arr f"
shows "map f = B.inv (τ (A.cod f)) ⋅⇩B G f"
using assms map_def by (simp add: τ'.map_def)
lemma is_natural_transformation:
shows "natural_transformation A B G F map"
by (simp add: τ'.natural_transformation_axioms map_def)
lemma inverts_components:
assumes "A.ide a"
shows "B.inverse_arrows (τ a) (map a)"
using assms τ.components_are_iso B.ide_is_iso B.inv_is_inverse B.inverse_arrows_def map_def
by (metis τ'.map_simp_ide)
end
sublocale inverse_transformation ⊆ natural_transformation A B G F map
using is_natural_transformation by auto
sublocale inverse_transformation ⊆ natural_isomorphism A B G F map
by (simp add: natural_isomorphism.intro natural_isomorphism_axioms.intro
natural_transformation_axioms)
lemma inverse_inverse_transformation [simp]:
assumes "natural_isomorphism A B F G τ"
shows "inverse_transformation.map A B F (inverse_transformation.map A B G τ) = τ"
proof -
interpret τ: natural_isomorphism A B F G τ
using assms by auto
interpret τ': inverse_transformation A B F G τ ..
interpret τ'': inverse_transformation A B G F τ'.map ..
show "τ''.map = τ"
using τ.natural_transformation_axioms τ''.natural_transformation_axioms
by (intro eqI, auto)
qed
locale inverse_transformations =
A: category A +
B: category B +
F: "functor" A B F +
G: "functor" A B G +
τ: natural_transformation A B F G τ +
τ': natural_transformation A B G F τ'
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and F :: "'a ⇒ 'b"
and G :: "'a ⇒ 'b"
and τ :: "'a ⇒ 'b"
and τ' :: "'a ⇒ 'b" +
assumes inv: "A.ide a ⟹ B.inverse_arrows (τ a) (τ' a)"
sublocale inverse_transformations ⊆ natural_isomorphism A B F G τ
by (meson B.category_axioms τ.natural_transformation_axioms B.iso_def inv
natural_isomorphism.intro natural_isomorphism_axioms.intro)
sublocale inverse_transformations ⊆ natural_isomorphism A B G F τ'
by (meson category.inverse_arrows_sym category.iso_def inverse_transformations_axioms
inverse_transformations_axioms_def inverse_transformations_def
natural_isomorphism.intro natural_isomorphism_axioms.intro)
lemma inverse_transformations_sym:
assumes "inverse_transformations A B F G σ σ'"
shows "inverse_transformations A B G F σ' σ"
using assms
by (simp add: category.inverse_arrows_sym inverse_transformations_axioms_def
inverse_transformations_def)
lemma inverse_transformations_inverse:
assumes "inverse_transformations A B F G σ σ'"
shows "vertical_composite.map A B σ σ' = F"
and "vertical_composite.map A B σ' σ = G"
proof -
interpret A: category A
using assms(1) inverse_transformations_def natural_transformation_def by blast
interpret inv: inverse_transformations A B F G σ σ' using assms by auto
interpret σσ': vertical_composite A B F G F σ σ' ..
show "vertical_composite.map A B σ σ' = F"
using σσ'.is_natural_transformation inv.F.natural_transformation_axioms
σσ'.map_simp_ide inv.B.comp_inv_arr inv.inv
by (intro eqI, simp_all)
interpret inv': inverse_transformations A B G F σ' σ
using assms inverse_transformations_sym by blast
interpret σ'σ: vertical_composite A B G F G σ' σ ..
show "vertical_composite.map A B σ' σ = G"
using σ'σ.is_natural_transformation inv.G.natural_transformation_axioms
σ'σ.map_simp_ide inv'.inv inv.B.comp_inv_arr
by (intro eqI, simp_all)
qed
lemma inverse_transformations_compose:
assumes "inverse_transformations A B F G σ σ'"
and "inverse_transformations A B G H τ τ'"
shows "inverse_transformations A B F H
(vertical_composite.map A B σ τ) (vertical_composite.map A B τ' σ')"
proof -
interpret A: category A using assms(1) inverse_transformations_def by blast
interpret B: category B using assms(1) inverse_transformations_def by blast
interpret σσ': inverse_transformations A B F G σ σ' using assms(1) by auto
interpret ττ': inverse_transformations A B G H τ τ' using assms(2) by auto
interpret στ: vertical_composite A B F G H σ τ ..
interpret τ'σ': vertical_composite A B H G F τ' σ' ..
show ?thesis
using B.inverse_arrows_compose σσ'.inv στ.map_simp_ide τ'σ'.map_simp_ide ττ'.inv
by (unfold_locales, auto)
qed
lemma vertical_composite_iso_inverse [simp]:
assumes "natural_isomorphism A B F G τ"
shows "vertical_composite.map A B τ (inverse_transformation.map A B G τ) = F"
proof -
interpret τ: natural_isomorphism A B F G τ using assms by auto
interpret τ': inverse_transformation A B F G τ ..
interpret ττ': vertical_composite A B F G F τ τ'.map ..
show ?thesis
using ττ'.is_natural_transformation τ.F.natural_transformation_axioms τ'.inverts_components
τ.B.comp_inv_arr ττ'.map_simp_ide
by (intro eqI, auto)
qed
lemma vertical_composite_inverse_iso [simp]:
assumes "natural_isomorphism A B F G τ"
shows "vertical_composite.map A B (inverse_transformation.map A B G τ) τ = G"
proof -
interpret τ: natural_isomorphism A B F G τ using assms by auto
interpret τ': inverse_transformation A B F G τ ..
interpret τ'τ: vertical_composite A B G F G τ'.map τ ..
show ?thesis
using τ'τ.is_natural_transformation τ.G.natural_transformation_axioms τ'.inverts_components
τ'τ.map_simp_ide τ.B.comp_arr_inv
by (intro eqI, auto)
qed
lemma natural_isomorphisms_compose:
assumes "natural_isomorphism A B F G σ" and "natural_isomorphism A B G H τ"
shows "natural_isomorphism A B F H (vertical_composite.map A B σ τ)"
proof -
interpret A: category A
using assms(1) natural_isomorphism_def natural_transformation_def by blast
interpret B: category B
using assms(1) natural_isomorphism_def natural_transformation_def by blast
interpret σ: natural_isomorphism A B F G σ using assms(1) by auto
interpret τ: natural_isomorphism A B G H τ using assms(2) by auto
interpret στ: vertical_composite A B F G H σ τ ..
interpret natural_isomorphism A B F H στ.map
using στ.map_simp_ide by (unfold_locales, auto)
show ?thesis ..
qed
lemma naturally_isomorphic_reflexive:
assumes "functor A B F"
shows "naturally_isomorphic A B F F"
proof -
interpret F: "functor" A B F using assms by auto
have "natural_isomorphism A B F F F" ..
thus ?thesis using naturally_isomorphic_def by blast
qed
lemma naturally_isomorphic_symmetric:
assumes "naturally_isomorphic A B F G"
shows "naturally_isomorphic A B G F"
proof -
obtain φ where φ: "natural_isomorphism A B F G φ"
using assms naturally_isomorphic_def by blast
interpret φ: natural_isomorphism A B F G φ
using φ by auto
interpret ψ: inverse_transformation A B F G φ ..
have "natural_isomorphism A B G F ψ.map" ..
thus ?thesis using naturally_isomorphic_def by blast
qed
lemma naturally_isomorphic_transitive [trans]:
assumes "naturally_isomorphic A B F G"
and "naturally_isomorphic A B G H"
shows "naturally_isomorphic A B F H"
proof -
obtain φ where φ: "natural_isomorphism A B F G φ"
using assms naturally_isomorphic_def by blast
interpret φ: natural_isomorphism A B F G φ
using φ by auto
obtain ψ where ψ: "natural_isomorphism A B G H ψ"
using assms naturally_isomorphic_def by blast
interpret ψ: natural_isomorphism A B G H ψ
using ψ by auto
interpret ψφ: vertical_composite A B F G H φ ψ ..
have "natural_isomorphism A B F H ψφ.map"
using φ ψ natural_isomorphisms_compose by blast
thus ?thesis
using naturally_isomorphic_def by blast
qed
section "Horizontal Composition"
text‹
Horizontal composition is a way of composing parallel natural transformations
@{term σ} from @{term F} to @{term G} and @{term τ} from @{term H} to @{term K},
where functors @{term F} and @{term G} map @{term A} to @{term B} and
@{term H} and @{term K} map @{term B} to @{term C}, to obtain a natural transformation
from @{term "H o F"} to @{term "K o G"}.
Since horizontal composition turns out to coincide with ordinary composition of
natural transformations as functions, there is little point in defining a cumbersome
locale for horizontal composite.
›
lemma horizontal_composite:
assumes "natural_transformation A B F G σ"
and "natural_transformation B C H K τ"
shows "natural_transformation A C (H o F) (K o G) (τ o σ)"
proof -
interpret σ: natural_transformation A B F G σ
using assms(1) by simp
interpret τ: natural_transformation B C H K τ
using assms(2) by simp
interpret HF: composite_functor A B C F H ..
interpret KG: composite_functor A B C G K ..
show "natural_transformation A C (H o F) (K o G) (τ o σ)"
using σ.is_extensional τ.is_extensional
apply (unfold_locales, auto)
apply (metis σ.is_natural_1 σ.preserves_reflects_arr τ.preserves_comp_1)
by (metis σ.is_natural_2 σ.preserves_reflects_arr τ.preserves_comp_2)
qed
lemma hcomp_ide_dom [simp]:
assumes "natural_transformation A B F G τ"
shows "τ o (identity_functor.map A) = τ"
proof -
interpret τ: natural_transformation A B F G τ using assms by auto
show "τ o τ.A.map = τ"
using τ.A.map_def τ.is_extensional by fastforce
qed
lemma hcomp_ide_cod [simp]:
assumes "natural_transformation A B F G τ"
shows "(identity_functor.map B) o τ = τ"
proof -
interpret τ: natural_transformation A B F G τ using assms by auto
show "τ.B.map o τ = τ"
using τ.B.map_def τ.is_extensional by auto
qed
text‹
Horizontal composition of a functor with a vertical composite.
›
lemma whisker_right:
assumes "functor A B F"
and "natural_transformation B C H K τ" and "natural_transformation B C K L τ'"
shows "(vertical_composite.map B C τ τ') o F = vertical_composite.map A C (τ o F) (τ' o F)"
proof -
interpret F: "functor" A B F using assms(1) by auto
interpret τ: natural_transformation B C H K τ using assms(2) by auto
interpret τ': natural_transformation B C K L τ' using assms(3) by auto
interpret τoF: natural_transformation A C ‹H o F› ‹K o F› ‹τ o F›
using τ.natural_transformation_axioms F.natural_transformation_axioms
horizontal_composite
by blast
interpret τ'oF: natural_transformation A C ‹K o F› ‹L o F› ‹τ' o F›
using τ'.natural_transformation_axioms F.natural_transformation_axioms
horizontal_composite
by blast
interpret τ'τ: vertical_composite B C H K L τ τ' ..
interpret τ'τoF: natural_transformation A C ‹H o F› ‹L o F› ‹τ'τ.map o F›
using τ'τ.natural_transformation_axioms F.natural_transformation_axioms
horizontal_composite
by blast
interpret τ'oF_τoF: vertical_composite A C ‹H o F› ‹K o F› ‹L o F› ‹τ o F› ‹τ' o F› ..
show ?thesis
using τ'oF_τoF.map_def τ'τ.map_def τ'τoF.is_extensional by auto
qed
text‹
Horizontal composition of a vertical composite with a functor.
›
lemma whisker_left:
assumes "functor B C K"
and "natural_transformation A B F G τ" and "natural_transformation A B G H τ'"
shows "K o (vertical_composite.map A B τ τ') = vertical_composite.map A C (K o τ) (K o τ')"
proof -
interpret K: "functor" B C K using assms(1) by auto
interpret τ: natural_transformation A B F G τ using assms(2) by auto
interpret τ': natural_transformation A B G H τ' using assms(3) by auto
interpret τ'τ: vertical_composite A B F G H τ τ' ..
interpret Koτ: natural_transformation A C ‹K o F› ‹K o G› ‹K o τ›
using τ.natural_transformation_axioms K.natural_transformation_axioms
horizontal_composite
by blast
interpret Koτ': natural_transformation A C ‹K o G› ‹K o H› ‹K o τ'›
using τ'.natural_transformation_axioms K.natural_transformation_axioms
horizontal_composite
by blast
interpret Koτ'τ: natural_transformation A C ‹K o F› ‹K o H› ‹K o τ'τ.map›
using τ'τ.natural_transformation_axioms K.natural_transformation_axioms
horizontal_composite
by blast
interpret Koτ'_Koτ: vertical_composite A C ‹K o F› ‹K o G› ‹K o H› ‹K o τ› ‹K o τ'› ..
show "K o τ'τ.map = Koτ'_Koτ.map"
using Koτ'_Koτ.map_def τ'τ.map_def Koτ'τ.is_extensional Koτ'_Koτ.map_simp_1 τ'τ.map_simp_1
by auto
qed
text‹
The interchange law for horizontal and vertical composition.
›
lemma interchange:
assumes "natural_transformation B C F G τ" and "natural_transformation B C G H ν"
and "natural_transformation C D K L σ" and "natural_transformation C D L M μ"
shows "vertical_composite.map C D σ μ ∘ vertical_composite.map B C τ ν =
vertical_composite.map B D (σ ∘ τ) (μ ∘ ν)"
proof -
interpret τ: natural_transformation B C F G τ
using assms(1) by auto
interpret ν: natural_transformation B C G H ν
using assms(2) by auto
interpret σ: natural_transformation C D K L σ
using assms(3) by auto
interpret μ: natural_transformation C D L M μ
using assms(4) by auto
interpret ντ: vertical_composite B C F G H τ ν ..
interpret μσ: vertical_composite C D K L M σ μ ..
interpret σoτ: natural_transformation B D ‹K o F› ‹L o G› ‹σ o τ›
using σ.natural_transformation_axioms τ.natural_transformation_axioms
horizontal_composite
by blast
interpret μoν: natural_transformation B D ‹L o G› ‹M o H› ‹μ o ν›
using μ.natural_transformation_axioms ν.natural_transformation_axioms
horizontal_composite
by blast
interpret μσoντ: natural_transformation B D ‹K o F› ‹M o H› ‹μσ.map o ντ.map›
using μσ.natural_transformation_axioms ντ.natural_transformation_axioms
horizontal_composite
by blast
interpret μoν_σoτ: vertical_composite B D ‹K o F› ‹L o G› ‹M o H› ‹σ o τ› ‹μ o ν› ..
show "μσ.map o ντ.map = μoν_σoτ.map"
proof (intro eqI)
show "natural_transformation B D (K ∘ F) (M ∘ H) (μσ.map o ντ.map)" ..
show "natural_transformation B D (K ∘ F) (M ∘ H) μoν_σoτ.map" ..
show "⋀a. τ.A.ide a ⟹ (μσ.map o ντ.map) a = μoν_σoτ.map a"
proof -
fix a
assume a: "τ.A.ide a"
have "(μσ.map o ντ.map) a = D (μ (H a)) (σ (C (ν a) (τ a)))"
using a μσ.map_simp_1 ντ.map_simp_2 by simp
also have "... = D (μ (ν a)) (σ (τ a))"
using a
by (metis (full_types) μ.is_natural_1 μσ.map_simp_1 μσ.preserves_comp_1
ντ.map_seq ντ.map_simp_1 ντ.preserves_cod σ.B.comp_assoc τ.A.ide_char τ.B.seqE)
also have "... = μoν_σoτ.map a"
using a μoν_σoτ.map_simp_ide by simp
finally show "(μσ.map o ντ.map) a = μoν_σoτ.map a" by blast
qed
qed
qed
text‹
A special-case of the interchange law in which two of the natural transformations
are functors. It comes up reasonably often, and the reasoning is awkward.
›
lemma interchange_spc:
assumes "natural_transformation B C F G σ"
and "natural_transformation C D H K τ"
shows "τ ∘ σ = vertical_composite.map B D (H o σ) (τ o G)"
and "τ ∘ σ = vertical_composite.map B D (τ o F) (K o σ)"
proof -
show "τ ∘ σ = vertical_composite.map B D (H ∘ σ) (τ ∘ G)"
proof -
have "vertical_composite.map C D H τ ∘ vertical_composite.map B C σ G =
vertical_composite.map B D (H ∘ σ) (τ ∘ G)"
by (meson assms functor_is_transformation interchange natural_transformation.axioms(3-4))
thus ?thesis
using assms by force
qed
show "τ ∘ σ = vertical_composite.map B D (τ ∘ F) (K ∘ σ)"
proof -
have "vertical_composite.map C D τ K ∘ vertical_composite.map B C F σ =
vertical_composite.map B D (τ ∘ F) (K ∘ σ)"
by (meson assms functor_is_transformation interchange natural_transformation.axioms(3-4))
thus ?thesis
using assms by force
qed
qed
end
Theory BinaryFunctor
chapter BinaryFunctor
theory BinaryFunctor
imports ProductCategory NaturalTransformation
begin
text‹
This theory develops various properties of binary functors, which are functors
defined on product categories.
›
locale binary_functor =
A1: category A1 +
A2: category A2 +
B: category B +
A1xA2: product_category A1 A2 +
"functor" A1xA2.comp B F
for A1 :: "'a1 comp" (infixr "⋅⇩A⇩1" 55)
and A2 :: "'a2 comp" (infixr "⋅⇩A⇩2" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and F :: "'a1 * 'a2 ⇒ 'b"
begin
notation A1.in_hom ("«_ : _ →⇩A⇩1 _»")
notation A2.in_hom ("«_ : _ →⇩A⇩2 _»")
end
text‹
A product functor is a binary functor obtained by placing two functors in parallel.
›
locale product_functor =
A1: category A1 +
A2: category A2 +
B1: category B1 +
B2: category B2 +
F1: "functor" A1 B1 F1 +
F2: "functor" A2 B2 F2 +
A1xA2: product_category A1 A2 +
B1xB2: product_category B1 B2
for A1 :: "'a1 comp" (infixr "⋅⇩A⇩1" 55)
and A2 :: "'a2 comp" (infixr "⋅⇩A⇩2" 55)
and B1 :: "'b1 comp" (infixr "⋅⇩B⇩1" 55)
and B2 :: "'b2 comp" (infixr "⋅⇩B⇩2" 55)
and F1 :: "'a1 ⇒ 'b1"
and F2 :: "'a2 ⇒ 'b2"
begin
notation A1xA2.comp (infixr "⋅⇩A⇩1⇩x⇩A⇩2" 55)
notation B1xB2.comp (infixr "⋅⇩B⇩1⇩x⇩B⇩2" 55)
notation A1.in_hom ("«_ : _ →⇩A⇩1 _»")
notation A2.in_hom ("«_ : _ →⇩A⇩2 _»")
notation B1.in_hom ("«_ : _ →⇩B⇩1 _»")
notation B2.in_hom ("«_ : _ →⇩B⇩2 _»")
notation A1xA2.in_hom ("«_ : _ →⇩A⇩1⇩x⇩A⇩2 _»")
notation B1xB2.in_hom ("«_ : _ →⇩B⇩1⇩x⇩B⇩2 _»")
definition map
where "map f = (if A1.arr (fst f) ∧ A2.arr (snd f)
then (F1 (fst f), F2 (snd f)) else B1xB2.null)"
lemma map_simp [simp]:
assumes "A1xA2.arr f"
shows "map f = (F1 (fst f), F2 (snd f))"
using assms map_def by simp
lemma is_functor:
shows "functor A1xA2.comp B1xB2.comp map"
using B1xB2.dom_char B1xB2.cod_char
apply (unfold_locales)
using map_def A1.arr_dom_iff_arr A1.arr_cod_iff_arr A2.arr_dom_iff_arr A2.arr_cod_iff_arr
apply auto[4]
using A1xA2.seqE map_simp by fastforce
end
sublocale product_functor ⊆ "functor" A1xA2.comp B1xB2.comp map
using is_functor by auto
sublocale product_functor ⊆ binary_functor A1 A2 B1xB2.comp map ..
text‹
A symmetry functor is a binary functor that exchanges its two arguments.
›
locale symmetry_functor =
A1: category A1 +
A2: category A2 +
A1xA2: product_category A1 A2 +
A2xA1: product_category A2 A1
for A1 :: "'a1 comp" (infixr "⋅⇩A⇩1" 55)
and A2 :: "'a2 comp" (infixr "⋅⇩A⇩2" 55)
begin
notation A1xA2.comp (infixr "⋅⇩A⇩1⇩x⇩A⇩2" 55)
notation A2xA1.comp (infixr "⋅⇩A⇩2⇩x⇩A⇩1" 55)
notation A1xA2.in_hom ("«_ : _ →⇩A⇩1⇩x⇩A⇩2 _»")
notation A2xA1.in_hom ("«_ : _ →⇩A⇩2⇩x⇩A⇩1 _»")
definition map :: "'a1 * 'a2 ⇒ 'a2 * 'a1"
where "map f = (if A1xA2.arr f then (snd f, fst f) else A2xA1.null)"
lemma map_simp [simp]:
assumes "A1xA2.arr f"
shows "map f = (snd f, fst f)"
using assms map_def by meson
lemma is_functor:
shows "functor A1xA2.comp A2xA1.comp map"
using map_def A1.arr_dom_iff_arr A1.arr_cod_iff_arr A2.arr_dom_iff_arr A2.arr_cod_iff_arr
apply (unfold_locales)
apply auto[4]
by force
end
sublocale symmetry_functor ⊆ "functor" A1xA2.comp A2xA1.comp map
using is_functor by auto
sublocale symmetry_functor ⊆ binary_functor A1 A2 A2xA1.comp map ..
context binary_functor
begin
abbreviation sym
where "sym ≡ (λf. F (snd f, fst f))"
lemma sym_is_binary_functor:
shows "binary_functor A2 A1 B sym"
proof -
interpret A2xA1: product_category A2 A1 ..
interpret S: symmetry_functor A2 A1 ..
interpret SF: composite_functor A2xA1.comp A1xA2.comp B S.map F ..
have "binary_functor A2 A1 B (F o S.map)" ..
moreover have "F o S.map = (λf. F (snd f, fst f))"
using is_extensional SF.is_extensional S.map_def by fastforce
ultimately show ?thesis using sym_def by auto
qed
text‹
Fixing one or the other argument of a binary functor to be an identity
yields a functor of the other argument.
›
lemma fixing_ide_gives_functor_1:
assumes "A1.ide a1"
shows "functor A2 B (λf2. F (a1, f2))"
using assms
apply unfold_locales
using is_extensional
apply auto[4]
by (metis A1.ideD(1) A1.comp_ide_self A1xA2.comp_simp A1xA2.seq_char fst_conv
preserves_comp_2 snd_conv)
lemma fixing_ide_gives_functor_2:
assumes "A2.ide a2"
shows "functor A1 B (λf1. F (f1, a2))"
using assms
apply (unfold_locales)
using is_extensional
apply auto[4]
by (metis A1xA2.comp_simp A1xA2.seq_char A2.ideD(1) A2.comp_ide_self fst_conv
preserves_comp_2 snd_conv)
text‹
Fixing one or the other argument of a binary functor to be an arrow
yields a natural transformation.
›
lemma fixing_arr_gives_natural_transformation_1:
assumes "A1.arr f1"
shows "natural_transformation A2 B (λf2. F (A1.dom f1, f2)) (λf2. F (A1.cod f1, f2))
(λf2. F (f1, f2))"
proof -
let ?Fdom = "λf2. F (A1.dom f1, f2)"
interpret Fdom: "functor" A2 B ?Fdom using assms fixing_ide_gives_functor_1 by auto
let ?Fcod = "λf2. F (A1.cod f1, f2)"
interpret Fcod: "functor" A2 B ?Fcod using assms fixing_ide_gives_functor_1 by auto
let ?τ = "λf2. F (f1, f2)"
show "natural_transformation A2 B ?Fdom ?Fcod ?τ"
using assms
apply unfold_locales
using is_extensional
apply auto[3]
using A1xA2.arr_char preserves_comp A1.comp_cod_arr A1xA2.comp_char A2.comp_arr_dom
apply (metis fst_conv snd_conv)
using A1xA2.arr_char preserves_comp A2.comp_cod_arr A1xA2.comp_char A1.comp_arr_dom
by (metis fst_conv snd_conv)
qed
lemma fixing_arr_gives_natural_transformation_2:
assumes "A2.arr f2"
shows "natural_transformation A1 B (λf1. F (f1, A2.dom f2)) (λf1. F (f1, A2.cod f2))
(λf1. F (f1, f2))"
proof -
interpret F': binary_functor A2 A1 B sym
using assms(1) sym_is_binary_functor by auto
have "natural_transformation A1 B (λf1. sym (A2.dom f2, f1)) (λf1. sym (A2.cod f2, f1))
(λf1. sym (f2, f1))"
using assms F'.fixing_arr_gives_natural_transformation_1 by fast
thus ?thesis by simp
qed
text‹
Fixing one or the other argument of a binary functor to be a composite arrow
yields a natural transformation that is a vertical composite.
›
lemma preserves_comp_1:
assumes "A1.seq f1' f1"
shows "(λf2. F (f1' ⋅⇩A⇩1 f1, f2)) =
vertical_composite.map A2 B (λf2. F (f1, f2)) (λf2. F (f1', f2))"
proof -
interpret τ: natural_transformation A2 B
‹λf2. F (A1.dom f1, f2)› ‹λf2. F (A1.cod f1, f2)› ‹λf2. F (f1, f2)›
using assms fixing_arr_gives_natural_transformation_1 by blast
interpret τ': natural_transformation A2 B
‹λf2. F (A1.cod f1, f2)› ‹λf2. F (A1.cod f1', f2)› ‹λf2. F (f1', f2)›
using assms fixing_arr_gives_natural_transformation_1 A1.seqE by metis
interpret τ'oτ: vertical_composite A2 B
‹λf2. F (A1.dom f1, f2)› ‹λf2. F (A1.cod f1, f2)› ‹λf2. F (A1.cod f1', f2)›
‹λf2. F (f1, f2)› ‹λf2. F (f1', f2)› ..
show "(λf2. F (f1' ⋅⇩A⇩1 f1, f2)) = τ'oτ.map"
proof
fix f2
have "¬A2.arr f2 ⟹ F (f1' ⋅⇩A⇩1 f1, f2) = τ'oτ.map f2"
using τ'oτ.is_extensional is_extensional by simp
moreover have "A2.arr f2 ⟹ F (f1' ⋅⇩A⇩1 f1, f2) = τ'oτ.map f2"
proof -
assume f2: "A2.arr f2"
have "F (f1' ⋅⇩A⇩1 f1, f2) = B (F (f1', f2)) (F (f1, A2.dom f2))"
using assms f2 preserves_comp A1xA2.arr_char A1xA2.comp_char A2.comp_arr_dom
by (metis fst_conv snd_conv)
also have "... = τ'oτ.map f2"
using f2 τ'oτ.map_simp_2 by simp
finally show "F (f1' ⋅⇩A⇩1 f1, f2) = τ'oτ.map f2" by auto
qed
ultimately show "F (f1' ⋅⇩A⇩1 f1, f2) = τ'oτ.map f2" by blast
qed
qed
lemma preserves_comp_2:
assumes "A2.seq f2' f2"
shows "(λf1. F (f1, f2' ⋅⇩A⇩2 f2)) =
vertical_composite.map A1 B (λf1. F (f1, f2)) (λf1. F (f1, f2'))"
proof -
interpret F': binary_functor A2 A1 B sym
using assms(1) sym_is_binary_functor by auto
have "(λf1. sym (f2' ⋅⇩A⇩2 f2, f1)) =
vertical_composite.map A1 B (λf1. sym (f2, f1)) (λf1. sym (f2', f1))"
using assms F'.preserves_comp_1 by fastforce
thus ?thesis by simp
qed
end
text‹
A binary functor transformation is a natural transformation between binary functors.
We need a certain property of such transformations; namely, that if one or the
other argument is fixed to be an identity, the result is a natural transformation.
›
locale binary_functor_transformation =
A1: category A1 +
A2: category A2 +
B: category B +
A1xA2: product_category A1 A2 +
F: binary_functor A1 A2 B F +
G: binary_functor A1 A2 B G +
natural_transformation A1xA2.comp B F G τ
for A1 :: "'a1 comp" (infixr "⋅⇩A⇩1" 55)
and A2 :: "'a2 comp" (infixr "⋅⇩A⇩2" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and F :: "'a1 * 'a2 ⇒ 'b"
and G :: "'a1 * 'a2 ⇒ 'b"
and τ :: "'a1 * 'a2 ⇒ 'b"
begin
notation A1xA2.comp (infixr "⋅⇩A⇩1⇩x⇩A⇩2" 55)
notation A1xA2.in_hom ("«_ : _ →⇩A⇩1⇩x⇩A⇩2 _»")
lemma fixing_ide_gives_natural_transformation_1:
assumes "A1.ide a1"
shows "natural_transformation A2 B (λf2. F (a1, f2)) (λf2. G (a1, f2)) (λf2. τ (a1, f2))"
proof -
interpret Fa1: "functor" A2 B ‹λf2. F (a1, f2)›
using assms F.fixing_ide_gives_functor_1 by simp
interpret Ga1: "functor" A2 B ‹λf2. G (a1, f2)›
using assms "G.fixing_ide_gives_functor_1" by simp
show ?thesis
using assms is_extensional is_natural_1 is_natural_2
apply (unfold_locales, auto)
apply (metis A1.ide_char)
by (metis A1.ide_char)
qed
lemma fixing_ide_gives_natural_transformation_2:
assumes "A2.ide a2"
shows "natural_transformation A1 B (λf1. F (f1, a2)) (λf1. G (f1, a2)) (λf1. τ (f1, a2))"
proof -
interpret Fa2: "functor" A1 B ‹λf1. F (f1, a2)›
using assms F.fixing_ide_gives_functor_2 by simp
interpret Ga2: "functor" A1 B ‹λf1. G (f1, a2)›
using assms "G.fixing_ide_gives_functor_2" by simp
show ?thesis
using assms is_extensional is_natural_1 is_natural_2
apply (unfold_locales, auto)
apply (metis A2.ide_char)
by (metis A2.ide_char)
qed
end
end
Theory FunctorCategory
chapter FunctorCategory
theory FunctorCategory
imports ConcreteCategory BinaryFunctor
begin
text‹
The functor category ‹[A, B]› is the category whose objects are functors
from @{term A} to @{term B} and whose arrows correspond to natural transformations
between these functors.
›
section "Construction"
text‹
Since the arrows of a functor category cannot (in the context of the present development)
be directly identified with natural transformations, but rather only with natural
transformations that have been equipped with their domain and codomain functors,
and since there is no natural value to serve as @{term null},
we use the general-purpose construction given by @{locale concrete_category} to define
this category.
›
locale functor_category =
A: category A +
B: category B
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
begin
notation A.in_hom ("«_ : _ →⇩A _»")
notation B.in_hom ("«_ : _ →⇩B _»")
type_synonym ('aa, 'bb) arr = "('aa ⇒ 'bb, 'aa ⇒ 'bb) concrete_category.arr"
sublocale concrete_category ‹Collect (functor A B)›
‹λF G. Collect (natural_transformation A B F G)› ‹λF. F›
‹λF G H τ σ. vertical_composite.map A B σ τ›
using vcomp_assoc
apply (unfold_locales, simp_all)
proof -
fix F G H σ τ
assume F: "functor (⋅⇩A) (⋅⇩B) F"
assume G: "functor (⋅⇩A) (⋅⇩B) G"
assume H: "functor (⋅⇩A) (⋅⇩B) H"
assume σ: "natural_transformation (⋅⇩A) (⋅⇩B) F G σ"
assume τ: "natural_transformation (⋅⇩A) (⋅⇩B) G H τ"
interpret F: "functor" A B F using F by simp
interpret G: "functor" A B G using G by simp
interpret H: "functor" A B H using H by simp
interpret σ: natural_transformation A B F G σ
using σ by simp
interpret τ: natural_transformation A B G H τ
using τ by simp
interpret τσ: vertical_composite A B F G H σ τ
..
show "natural_transformation (⋅⇩A) (⋅⇩B) F H (vertical_composite.map (⋅⇩A) (⋅⇩B) σ τ)"
using τσ.map_def τσ.is_natural_transformation by simp
qed
abbreviation comp (infixr "⋅" 55)
where "comp ≡ COMP"
notation in_hom ("«_ : _ → _»")
lemma arrI [intro]:
assumes "f ≠ null" and "natural_transformation A B (Dom f) (Cod f) (Map f)"
shows "arr f"
using assms arr_char null_char
by (simp add: natural_transformation_def)
lemma arrE [elim]:
assumes "arr f"
and "f ≠ null ⟹ natural_transformation A B (Dom f) (Cod f) (Map f) ⟹ T"
shows T
using assms arr_char null_char by simp
lemma arr_MkArr [iff]:
shows "arr (MkArr F G τ) ⟷ natural_transformation A B F G τ"
using arr_char null_char arr_MkArr natural_transformation_def by fastforce
lemma ide_char [iff]:
shows "ide t ⟷ t ≠ null ∧ functor A B (Map t) ∧ Dom t = Map t ∧ Cod t = Map t"
using ide_char null_char by fastforce
end
section "Additional Properties"
text‹
In this section some additional facts are proved, which make it easier to
work with the @{term "functor_category"} locale.
›
context functor_category
begin
lemma Map_comp [simp]:
assumes "seq t' t" and "A.seq a' a"
shows "Map (t' ⋅ t) (a' ⋅⇩A a) = Map t' a' ⋅⇩B Map t a"
proof -
interpret t: natural_transformation A B ‹Dom t› ‹Cod t› ‹Map t›
using assms(1) arr_char seq_char by blast
interpret t': natural_transformation A B ‹Cod t› ‹Cod t'› ‹Map t'›
using assms(1) arr_char seq_char by force
interpret t'ot: vertical_composite A B ‹Dom t› ‹Cod t› ‹Cod t'› ‹Map t› ‹Map t'› ..
show ?thesis
proof -
have "Map (t' ⋅ t) = t'ot.map"
using assms(1) seq_char t'ot.natural_transformation_axioms by simp
thus ?thesis
using assms(2) t'ot.map_simp_2 t'.preserves_comp_2 B.comp_assoc by auto
qed
qed
lemma Map_comp':
assumes "seq t' t"
shows "Map (t' ⋅ t) = vertical_composite.map A B (Map t) (Map t')"
proof -
interpret t: natural_transformation A B ‹Dom t› ‹Cod t› ‹Map t›
using assms(1) arr_char seq_char by blast
interpret t': natural_transformation A B ‹Cod t› ‹Cod t'› ‹Map t'›
using assms(1) arr_char seq_char by force
interpret t'ot: vertical_composite A B ‹Dom t› ‹Cod t› ‹Cod t'› ‹Map t› ‹Map t'› ..
show ?thesis
using assms(1) seq_char t'ot.natural_transformation_axioms by simp
qed
lemma MkArr_eqI [intro]:
assumes "arr (MkArr F G τ)"
and "F = F'" and "G = G'" and "τ = τ'"
shows "MkArr F G τ = MkArr F' G' τ'"
using assms arr_eqI by simp
lemma MkArr_eqI' [intro]:
assumes "arr (MkArr F G τ)" and "τ = τ'"
shows "MkArr F G τ = MkArr F G τ'"
using assms arr_eqI by simp
lemma iso_char [iff]:
shows "iso t ⟷ t ≠ null ∧ natural_isomorphism A B (Dom t) (Cod t) (Map t)"
proof
assume t: "iso t"
show "t ≠ null ∧ natural_isomorphism A B (Dom t) (Cod t) (Map t)"
proof
show "t ≠ null" using t arr_char iso_is_arr by auto
from t obtain t' where t': "inverse_arrows t t'" by blast
interpret τ: natural_transformation A B ‹Dom t› ‹Cod t› ‹Map t›
using t arr_char iso_is_arr by auto
interpret τ': natural_transformation A B ‹Cod t› ‹Dom t› ‹Map t'›
using t' arr_char dom_char seq_char
by (metis arrE ide_compE inverse_arrowsE)
interpret τ'oτ: vertical_composite A B ‹Dom t› ‹Cod t› ‹Dom t› ‹Map t› ‹Map t'› ..
interpret τoτ': vertical_composite A B ‹Cod t› ‹Dom t› ‹Cod t› ‹Map t'› ‹Map t› ..
show "natural_isomorphism A B (Dom t) (Cod t) (Map t)"
proof
fix a
assume a: "A.ide a"
show "B.iso (Map t a)"
proof
have 1: "τ'oτ.map = Dom t ∧ τoτ'.map = Cod t"
using t t'
by (metis (no_types, lifting) Map_dom concrete_category.Map_comp
concrete_category_axioms ide_compE inverse_arrowsE seq_char)
show "B.inverse_arrows (Map t a) (Map t' a)"
using a 1 τoτ'.map_simp_ide τ'oτ.map_simp_ide τ.F.preserves_ide τ.G.preserves_ide
by auto
qed
qed
qed
next
assume t: "t ≠ null ∧ natural_isomorphism A B (Dom t) (Cod t) (Map t)"
show "iso t"
proof
interpret τ: natural_isomorphism A B ‹Dom t› ‹Cod t› ‹Map t›
using t by auto
interpret τ': inverse_transformation A B ‹Dom t› ‹Cod t› ‹Map t› ..
have 1: "vertical_composite.map A B (Map t) τ'.map = Dom t ∧
vertical_composite.map A B τ'.map (Map t) = Cod t"
using τ.natural_isomorphism_axioms vertical_composite_inverse_iso
vertical_composite_iso_inverse
by blast
show "inverse_arrows t (MkArr (Cod t) (Dom t) (τ'.map))"
proof
show 2: "ide (MkArr (Cod t) (Dom t) τ'.map ⋅ t)"
using t 1
by (metis (no_types, lifting) MkArr_Map MkIde_Dom τ'.natural_transformation_axioms
τ.natural_transformation_axioms arrI arr_MkArr comp_MkArr ide_dom)
show "ide (t ⋅ MkArr (Cod t) (Dom t) τ'.map)"
using t 1 2
by (metis Dom.simps(1) Map.simps(1) τ.natural_transformation_axioms arrI
cod_char cod_comp comp_char ide_char' ide_compE)
qed
qed
qed
end
section "Evaluation Functor"
text‹
This section defines the evaluation map that applies an arrow of the functor
category ‹[A, B]› to an arrow of @{term A} to obtain an arrow of @{term B}
and shows that it is functorial.
›
locale evaluation_functor =
A: category A +
B: category B +
A_B: functor_category A B +
A_BxA: product_category A_B.comp A
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
begin
notation A_B.comp (infixr "⋅⇩[⇩A⇩,⇩B⇩]" 55)
notation A_BxA.comp (infixr "⋅⇩[⇩A⇩,⇩B⇩]⇩x⇩A" 55)
notation A_B.in_hom ("«_ : _ →⇩[⇩A⇩,⇩B⇩] _»")
notation A_BxA.in_hom ("«_ : _ →⇩[⇩A⇩,⇩B⇩]⇩x⇩A _»")
definition map
where "map Fg ≡ if A_BxA.arr Fg then A_B.Map (fst Fg) (snd Fg) else B.null"
lemma map_simp:
assumes "A_BxA.arr Fg"
shows "map Fg = A_B.Map(fst Fg) (snd Fg)"
using assms map_def by auto
lemma is_functor:
shows "functor A_BxA.comp B map"
proof
show "⋀Fg. ¬ A_BxA.arr Fg ⟹ map Fg = B.null"
using map_def by auto
fix Fg
assume Fg: "A_BxA.arr Fg"
let ?F = "fst Fg" and ?g = "snd Fg"
have F: "A_B.arr ?F" using Fg by auto
have g: "A.arr ?g" using Fg by auto
have DomF: "A_B.Dom ?F = A_B.Map (A_B.dom ?F)" using F by simp
have CodF: "A_B.Cod ?F = A_B.Map (A_B.cod ?F)" using F by simp
interpret F: natural_transformation A B ‹A_B.Dom ?F› ‹A_B.Cod ?F› ‹A_B.Map ?F›
using Fg A_B.arr_char [of ?F] by blast
show "B.arr (map Fg)" using Fg map_def by auto
show "B.dom (map Fg) = map (A_BxA.dom Fg)"
using g Fg map_def DomF
by (metis (no_types, lifting) A_BxA.arr_dom A_BxA.dom_simp F.preserves_dom
fst_conv snd_conv)
show "B.cod (map Fg) = map (A_BxA.cod Fg)"
using g Fg map_def CodF
by (metis (no_types, lifting) A_BxA.arr_cod A_BxA.cod_simp F.preserves_cod
fst_conv snd_conv)
next
fix Fg Fg'
assume 1: "A_BxA.seq Fg' Fg"
let ?F = "fst Fg" and ?g = "snd Fg"
let ?F' = "fst Fg'" and ?g' = "snd Fg'"
have F': "A_B.arr ?F'" using 1 A_BxA.seqE by blast
have CodF: "A_B.Cod ?F = A_B.Map (A_B.cod ?F)"
using 1 by (metis A_B.Map_cod A_B.seqE A_BxA.seqE)
have DomF': "A_B.Dom ?F' = A_B.Map (A_B.dom ?F')"
using F' by simp
have seq_F'F: "A_B.seq ?F' ?F" using 1 by blast
have seq_g'g: "A.seq ?g' ?g" using 1 by blast
interpret F: natural_transformation A B ‹A_B.Dom ?F› ‹A_B.Cod ?F› ‹A_B.Map ?F›
using 1 A_B.arr_char by blast
interpret F': natural_transformation A B ‹A_B.Cod ?F› ‹A_B.Cod ?F'› ‹A_B.Map ?F'›
using 1 A_B.arr_char seq_F'F CodF DomF' A_B.seqE
by (metis mem_Collect_eq)
interpret F'oF: vertical_composite A B ‹A_B.Dom ?F› ‹A_B.Cod ?F› ‹A_B.Cod ?F'›
‹A_B.Map ?F› ‹A_B.Map ?F'› ..
show "map (Fg' ⋅⇩[⇩A⇩,⇩B⇩]⇩x⇩A Fg) = map Fg' ⋅⇩B map Fg"
unfolding map_def
using 1 seq_F'F seq_g'g by auto
qed
end
sublocale evaluation_functor ⊆ "functor" A_BxA.comp B map
using is_functor by auto
sublocale evaluation_functor ⊆ binary_functor A_B.comp A B map ..
section "Currying"
text‹
This section defines the notion of currying of a natural transformation
between binary functors, to obtain a natural transformation between
functors into a functor category, along with the inverse operation of uncurrying.
We have only proved here what is needed to establish the results
in theory ‹Limit› about limits in functor categories and have not
attempted to fully develop the functoriality and naturality properties of
these notions.
›
locale currying =
A1: category A1 +
A2: category A2 +
B: category B
for A1 :: "'a1 comp" (infixr "⋅⇩A⇩1" 55)
and A2 :: "'a2 comp" (infixr "⋅⇩A⇩2" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
begin
interpretation A1xA2: product_category A1 A2 ..
interpretation A2_B: functor_category A2 B ..
interpretation A2_BxA2: product_category A2_B.comp A2 ..
interpretation E: evaluation_functor A2 B ..
notation A1xA2.comp (infixr "⋅⇩A⇩1⇩x⇩A⇩2" 55)
notation A2_B.comp (infixr "⋅⇩[⇩A⇩2,⇩B⇩]" 55)
notation A2_BxA2.comp (infixr "⋅⇩[⇩A⇩2⇩,⇩B⇩]⇩x⇩A⇩2" 55)
notation A1xA2.in_hom ("«_ : _ →⇩A⇩1⇩x⇩A⇩2 _»")
notation A2_B.in_hom ("«_ : _ →⇩[⇩A⇩2⇩,⇩B⇩] _»")
notation A2_BxA2.in_hom ("«_ : _ →⇩[⇩A⇩2⇩,⇩B⇩]⇩x⇩A⇩2 _»")
text‹
A proper definition for @{term curry} requires that it be parametrized by
binary functors @{term F} and @{term G} that are the domain and codomain
of the natural transformations to which it is being applied.
Similar parameters are not needed in the case of @{term uncurry}.
›
definition curry :: "('a1 × 'a2 ⇒ 'b) ⇒ ('a1 × 'a2 ⇒ 'b) ⇒ ('a1 × 'a2 ⇒ 'b)
⇒ 'a1 ⇒ ('a2, 'b) A2_B.arr"
where "curry F G τ f1 = (if A1.arr f1 then
A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2))
(λf2. τ (f1, f2))
else A2_B.null)"
definition uncurry :: "('a1 ⇒ ('a2, 'b) A2_B.arr) ⇒ 'a1 × 'a2 ⇒ 'b"
where "uncurry τ f ≡ if A1xA2.arr f then E.map (τ (fst f), snd f) else B.null"
lemma curry_simp:
assumes "A1.arr f1"
shows "curry F G τ f1 = A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2))
(λf2. τ (f1, f2))"
using assms curry_def by auto
lemma uncurry_simp:
assumes "A1xA2.arr f"
shows "uncurry τ f = E.map (τ (fst f), snd f)"
using assms uncurry_def by auto
lemma curry_in_hom:
assumes f1: "A1.arr f1"
and "natural_transformation A1xA2.comp B F G τ"
shows "«curry F G τ f1 : curry F F F (A1.dom f1) →⇩[⇩A⇩2⇩,⇩B⇩] curry G G G (A1.cod f1)»"
proof -
interpret τ: natural_transformation A1xA2.comp B F G τ using assms by auto
show ?thesis
proof -
interpret F_dom_f1: "functor" A2 B ‹λf2. F (A1.dom f1, f2)›
using f1 τ.F.is_extensional apply (unfold_locales, simp_all)
by (metis A1.arr_dom A1.comp_arr_dom A1.dom_dom A1xA2.comp_simp A1xA2.seqI
τ.F.preserves_comp_2 fst_conv snd_conv)
interpret G_cod_f1: "functor" A2 B ‹λf2. G (A1.cod f1, f2)›
using f1 τ.G.is_extensional A1.arr_cod_iff_arr
apply (unfold_locales, simp_all)
by (metis A1.comp_arr_dom A1.dom_cod A1xA2.comp_simp A1xA2.seqI
τ.G.preserves_comp fst_conv snd_conv)
have "natural_transformation A2 B (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2))
(λf2. τ (f1, f2))"
using f1 τ.is_extensional apply (unfold_locales, simp_all)
proof -
fix f2
assume f2: "A2.arr f2"
show "G (A1.cod f1, f2) ⋅⇩B τ (f1, A2.dom f2) = τ (f1, f2)"
using f1 f2 τ.preserves_comp_1 [of "(A1.cod f1, f2)" "(f1, A2.dom f2)"]
A1.comp_cod_arr A2.comp_arr_dom
by simp
show "τ (f1, A2.cod f2) ⋅⇩B F (A1.dom f1, f2) = τ (f1, f2)"
using f1 f2 τ.preserves_comp_2 [of "(f1, A2.cod f2)" "(A1.dom f1, f2)"]
A1.comp_arr_dom A2.comp_cod_arr
by simp
qed
thus ?thesis
using f1 curry_simp by auto
qed
qed
lemma curry_preserves_functors:
assumes "functor A1xA2.comp B F"
shows "functor A1 A2_B.comp (curry F F F)"
proof -
interpret F: "functor" A1xA2.comp B F using assms by auto
interpret F: binary_functor A1 A2 B F ..
show ?thesis
using curry_def F.fixing_arr_gives_natural_transformation_1
A2_B.comp_char F.preserves_comp_1 curry_simp A2_B.seq_char
apply unfold_locales by auto
qed
lemma curry_preserves_transformations:
assumes "natural_transformation A1xA2.comp B F G τ"
shows "natural_transformation A1 A2_B.comp (curry F F F) (curry G G G) (curry F G τ)"
proof -
interpret τ: natural_transformation A1xA2.comp B F G τ using assms by auto
interpret τ: binary_functor_transformation A1 A2 B F G τ ..
interpret curry_F: "functor" A1 A2_B.comp ‹curry F F F›
using curry_preserves_functors τ.F.functor_axioms by simp
interpret curry_G: "functor" A1 A2_B.comp ‹curry G G G›
using curry_preserves_functors τ.G.functor_axioms by simp
show ?thesis
proof
show "⋀f2. ¬ A1.arr f2 ⟹ curry F G τ f2 = A2_B.null"
using curry_def by simp
fix f1
assume f1: "A1.arr f1"
show "A2_B.dom (curry F G τ f1) = curry F F F (A1.dom f1)"
using assms f1 curry_in_hom by blast
show "A2_B.cod (curry F G τ f1) = curry G G G (A1.cod f1)"
using assms f1 curry_in_hom by blast
show "curry G G G f1 ⋅⇩[⇩A⇩2,⇩B⇩] curry F G τ (A1.dom f1) = curry F G τ f1"
proof -
interpret τ_dom_f1: natural_transformation A2 B ‹λf2. F (A1.dom f1, f2)›
‹λf2. G (A1.dom f1, f2)› ‹λf2. τ (A1.dom f1, f2)›
using assms f1 curry_in_hom A1.ide_dom τ.fixing_ide_gives_natural_transformation_1
by blast
interpret G_f1: natural_transformation A2 B
‹λf2. G (A1.dom f1, f2)› ‹λf2. G (A1.cod f1, f2)› ‹λf2. G (f1, f2)›
using f1 τ.G.fixing_arr_gives_natural_transformation_1 by simp
interpret G_f1oτ_dom_f1: vertical_composite A2 B
‹λf2. F (A1.dom f1, f2)› ‹λf2. G (A1.dom f1, f2)›
‹λf2. G (A1.cod f1, f2)›
‹λf2. τ (A1.dom f1, f2)› ‹λf2. G (f1, f2)› ..
have "curry G G G f1 ⋅⇩[⇩A⇩2,⇩B⇩] curry F G τ (A1.dom f1)
= A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2)) G_f1oτ_dom_f1.map"
proof -
have "A2_B.seq (curry G G G f1) (curry F G τ (A1.dom f1))"
using f1 curry_in_hom [of "A1.dom f1"] τ.natural_transformation_axioms by force
thus ?thesis
using f1 curry_simp A2_B.comp_char [of "curry G G G f1" "curry F G τ (A1.dom f1)"]
by simp
qed
also have "... = A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2))
(λf2. τ (f1, f2))"
proof (intro A2_B.MkArr_eqI)
show "(λf2. F (A1.dom f1, f2)) = (λf2. F (A1.dom f1, f2))" by simp
show "(λf2. G (A1.cod f1, f2)) = (λf2. G (A1.cod f1, f2))" by simp
show "A2_B.arr (A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2))
G_f1oτ_dom_f1.map)"
using G_f1oτ_dom_f1.natural_transformation_axioms by blast
show "G_f1oτ_dom_f1.map = (λf2. τ (f1, f2))"
proof
fix f2
have "¬A2.arr f2 ⟹ G_f1oτ_dom_f1.map f2 = (λf2. τ (f1, f2)) f2"
using f1 G_f1oτ_dom_f1.is_extensional τ.is_extensional by simp
moreover have "A2.arr f2 ⟹ G_f1oτ_dom_f1.map f2 = (λf2. τ (f1, f2)) f2"
proof -
interpret τ_f1: natural_transformation A2 B ‹λf2. F (A1.dom f1, f2)›
‹λf2. G (A1.cod f1, f2)› ‹λf2. τ (f1, f2)›
using assms f1 curry_in_hom [of f1] curry_simp by auto
fix f2
assume f2: "A2.arr f2"
show "G_f1oτ_dom_f1.map f2 = (λf2. τ (f1, f2)) f2"
using f1 f2 G_f1oτ_dom_f1.map_simp_2 B.comp_assoc τ.is_natural_1
by fastforce
qed
ultimately show "G_f1oτ_dom_f1.map f2 = (λf2. τ (f1, f2)) f2" by blast
qed
qed
also have "... = curry F G τ f1" using f1 curry_def by simp
finally show ?thesis by blast
qed
show "curry F G τ (A1.cod f1) ⋅⇩[⇩A⇩2,⇩B⇩] curry F F F f1 = curry F G τ f1"
proof -
interpret τ_cod_f1: natural_transformation A2 B ‹λf2. F (A1.cod f1, f2)›
‹λf2. G (A1.cod f1, f2)› ‹λf2. τ (A1.cod f1, f2)›
using assms f1 curry_in_hom A1.ide_cod τ.fixing_ide_gives_natural_transformation_1
by blast
interpret F_f1: natural_transformation A2 B
‹λf2. F (A1.dom f1, f2)› ‹λf2. F (A1.cod f1, f2)› ‹λf2. F (f1, f2)›
using f1 τ.F.fixing_arr_gives_natural_transformation_1 by simp
interpret τ_cod_f1oF_f1: vertical_composite A2 B
‹λf2. F (A1.dom f1, f2)› ‹λf2. F (A1.cod f1, f2)›
‹λf2. G (A1.cod f1, f2)›
‹λf2. F (f1, f2)› ‹λf2. τ (A1.cod f1, f2)› ..
have "curry F G τ (A1.cod f1) ⋅⇩[⇩A⇩2,⇩B⇩] curry F F F f1
= A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2)) τ_cod_f1oF_f1.map"
proof -
have
"curry F F F f1 =
A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. F (A1.cod f1, f2))
(λf2. F (f1, f2)) ∧
«curry F F F f1 : curry F F F (A1.dom f1) →⇩[⇩A⇩2⇩,⇩B⇩] curry F F F (A1.cod f1)»"
using f1 curry_F.preserves_hom curry_simp by blast
moreover have
"curry F G τ (A1.dom f1) =
A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.dom f1, f2))
(λf2. τ (A1.dom f1, f2)) ∧
«curry F G τ (A1.cod f1) :
curry F F F (A1.cod f1) →⇩[⇩A⇩2⇩,⇩B⇩] curry G G G (A1.cod f1)»"
using assms f1 curry_in_hom [of "A1.cod f1"] curry_def A1.arr_cod_iff_arr by simp
ultimately show ?thesis
using f1 curry_def by fastforce
qed
also have "... = A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2))
(λf2. τ (f1, f2))"
proof (intro A2_B.MkArr_eqI)
show "(λf2. F (A1.dom f1, f2)) = (λf2. F (A1.dom f1, f2))" by simp
show "(λf2. G (A1.cod f1, f2)) = (λf2. G (A1.cod f1, f2))" by simp
show "A2_B.arr (A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2))
τ_cod_f1oF_f1.map)"
using τ_cod_f1oF_f1.natural_transformation_axioms by blast
show "τ_cod_f1oF_f1.map = (λf2. τ (f1, f2))"
proof
fix f2
have "¬A2.arr f2 ⟹ τ_cod_f1oF_f1.map f2 = (λf2. τ (f1, f2)) f2"
using f1 by (simp add: τ.is_extensional τ_cod_f1oF_f1.is_extensional)
moreover have "A2.arr f2 ⟹ τ_cod_f1oF_f1.map f2 = (λf2. τ (f1, f2)) f2"
proof -
interpret τ_f1: natural_transformation A2 B ‹λf2. F (A1.dom f1, f2)›
‹λf2. G (A1.cod f1, f2)› ‹λf2. τ (f1, f2)›
using assms f1 curry_in_hom [of f1] curry_simp by auto
fix f2
assume f2: "A2.arr f2"
show "τ_cod_f1oF_f1.map f2 = (λf2. τ (f1, f2)) f2"
using f1 f2 τ_cod_f1oF_f1.map_simp_1 B.comp_assoc τ.is_natural_2
by fastforce
qed
ultimately show "τ_cod_f1oF_f1.map f2 = (λf2. τ (f1, f2)) f2" by blast
qed
qed
also have "... = curry F G τ f1" using f1 curry_def by simp
finally show ?thesis by blast
qed
qed
qed
lemma uncurry_preserves_functors:
assumes "functor A1 A2_B.comp F"
shows "functor A1xA2.comp B (uncurry F)"
proof -
interpret F: "functor" A1 A2_B.comp F using assms by auto
show ?thesis
using uncurry_def
apply (unfold_locales)
apply auto[4]
proof -
fix f g :: "'a1 * 'a2"
let ?f1 = "fst f"
let ?f2 = "snd f"
let ?g1 = "fst g"
let ?g2 = "snd g"
assume fg: "A1xA2.seq g f"
have f: "A1xA2.arr f" using fg A1xA2.seqE by blast
have f1: "A1.arr ?f1" using f by auto
have f2: "A2.arr ?f2" using f by auto
have g: "«g : A1xA2.cod f →⇩A⇩1⇩x⇩A⇩2 A1xA2.cod g»"
using fg A1xA2.dom_char A1xA2.cod_char
by (elim A1xA2.seqE, intro A1xA2.in_homI, auto)
let ?g1 = "fst g"
let ?g2 = "snd g"
have g1: "«?g1 : A1.cod ?f1 →⇩A⇩1 A1.cod ?g1»"
using f g by (intro A1.in_homI, auto)
have g2: "«?g2 : A2.cod ?f2 →⇩A⇩2 A2.cod ?g2»"
using f g by (intro A2.in_homI, auto)
interpret Ff1: natural_transformation A2 B ‹A2_B.Dom (F ?f1)› ‹A2_B.Cod (F ?f1)›
‹A2_B.Map (F ?f1)›
using f A2_B.arr_char [of "F ?f1"] by auto
interpret Fg1: natural_transformation A2 B ‹A2_B.Cod (F ?f1)› ‹A2_B.Cod (F ?g1)›
‹A2_B.Map (F ?g1)›
using f1 g1 A2_B.arr_char F.preserves_arr
A2_B.Map_dom [of "F ?g1"] A2_B.Map_cod [of "F ?f1"]
by fastforce
interpret Fg1oFf1: vertical_composite A2 B
‹A2_B.Dom (F ?f1)› ‹A2_B.Cod (F ?f1)› ‹A2_B.Cod (F ?g1)›
‹A2_B.Map (F ?f1)› ‹A2_B.Map (F ?g1)› ..
show "uncurry F (g ⋅⇩A⇩1⇩x⇩A⇩2 f) = uncurry F g ⋅⇩B uncurry F f"
using f1 g1 g2 g2 f g fg E.map_simp uncurry_def by auto
qed
qed
lemma uncurry_preserves_transformations:
assumes "natural_transformation A1 A2_B.comp F G τ"
shows "natural_transformation A1xA2.comp B (uncurry F) (uncurry G) (uncurry τ)"
proof -
interpret τ: natural_transformation A1 A2_B.comp F G τ using assms by auto
interpret "functor" A1xA2.comp B ‹uncurry F›
using τ.F.functor_axioms uncurry_preserves_functors by blast
interpret "functor" A1xA2.comp B ‹uncurry G›
using τ.G.functor_axioms uncurry_preserves_functors by blast
show ?thesis
proof
fix f
show "¬ A1xA2.arr f ⟹ uncurry τ f = B.null"
using uncurry_def by auto
assume f: "A1xA2.arr f"
let ?f1 = "fst f"
let ?f2 = "snd f"
show "B.dom (uncurry τ f) = uncurry F (A1xA2.dom f)"
using f uncurry_def by simp
show "B.cod (uncurry τ f) = uncurry G (A1xA2.cod f)"
using f uncurry_def by simp
show "uncurry G f ⋅⇩B uncurry τ (A1xA2.dom f) = uncurry τ f"
using f uncurry_def τ.is_natural_1 A2_BxA2.seq_char A2.comp_arr_dom
E.preserves_comp [of "(G (fst f), snd f)" "(τ (A1.dom (fst f)), A2.dom (snd f))"]
by auto
show "uncurry τ (A1xA2.cod f) ⋅⇩B uncurry F f = uncurry τ f"
proof -
have 1: "A1.arr ?f1 ∧ A1.arr (fst (A1.cod ?f1, A2.cod ?f2)) ∧
A1.cod ?f1 = A1.dom (fst (A1.cod ?f1, A2.cod ?f2)) ∧
A2.seq (snd (A1.cod ?f1, A2.cod ?f2)) ?f2"
using f A1.arr_cod_iff_arr A2.arr_cod_iff_arr by auto
hence 2:
"?f2 = A2 (snd (τ (fst (A1xA2.cod f)), snd (A1xA2.cod f))) (snd (F ?f1, ?f2))"
using f A2.comp_cod_arr by simp
have "A2_B.arr (τ ?f1)" using 1 by force
thus ?thesis
unfolding uncurry_def E.map_def
using f 1 2
apply simp
by (metis (no_types, lifting) A2_B.Map_comp ‹A2_B.arr (τ (fst f))› τ.is_natural_2)
qed
qed
qed
lemma uncurry_curry:
assumes "natural_transformation A1xA2.comp B F G τ"
shows "uncurry (curry F G τ) = τ"
proof
interpret τ: natural_transformation A1xA2.comp B F G τ using assms by auto
interpret curry_τ: natural_transformation A1 A2_B.comp ‹curry F F F› ‹curry G G G›
‹curry F G τ›
using assms curry_preserves_transformations by auto
fix f
have "¬A1xA2.arr f ⟹ uncurry (curry F G τ) f = τ f"
using curry_def uncurry_def τ.is_extensional by auto
moreover have "A1xA2.arr f ⟹ uncurry (curry F G τ) f = τ f"
proof -
assume f: "A1xA2.arr f"
have 1: "A2_B.Map (curry F G τ (fst f)) (snd f) = τ (fst f, snd f)"
using f A1xA2.arr_char curry_def by simp
thus "uncurry (curry F G τ) f = τ f"
unfolding uncurry_def E.map_def
using f 1 A1xA2.arr_char [of f] by simp
qed
ultimately show "uncurry (curry F G τ) f = τ f" by blast
qed
lemma curry_uncurry:
assumes "functor A1 A2_B.comp F" and "functor A1 A2_B.comp G"
and "natural_transformation A1 A2_B.comp F G τ"
shows "curry (uncurry F) (uncurry G) (uncurry τ) = τ"
proof
interpret F: "functor" A1 A2_B.comp F using assms(1) by auto
interpret G: "functor" A1 A2_B.comp G using assms(2) by auto
interpret τ: natural_transformation A1 A2_B.comp F G τ using assms(3) by auto
interpret uncurry_F: "functor" A1xA2.comp B ‹uncurry F›
using F.functor_axioms uncurry_preserves_functors by auto
interpret uncurry_G: "functor" A1xA2.comp B ‹uncurry G›
using G.functor_axioms uncurry_preserves_functors by auto
fix f1
have "¬A1.arr f1 ⟹ curry (uncurry F) (uncurry G) (uncurry τ) f1 = τ f1"
using curry_def uncurry_def τ.is_extensional by simp
moreover have "A1.arr f1 ⟹ curry (uncurry F) (uncurry G) (uncurry τ) f1 = τ f1"
proof -
assume f1: "A1.arr f1"
interpret uncurry_τ:
natural_transformation A1xA2.comp B ‹uncurry F› ‹uncurry G› ‹uncurry τ›
using τ.natural_transformation_axioms uncurry_preserves_transformations [of F G τ]
by simp
have "curry (uncurry F) (uncurry G) (uncurry τ) f1 =
A2_B.MkArr (λf2. uncurry F (A1.dom f1, f2)) (λf2. uncurry G (A1.cod f1, f2))
(λf2. uncurry τ (f1, f2))"
using f1 curry_def by simp
also have "... = A2_B.MkArr (λf2. uncurry F (A1.dom f1, f2))
(λf2. uncurry G (A1.cod f1, f2))
(λf2. E.map (τ f1, f2))"
proof -
have "(λf2. uncurry τ (f1, f2)) = (λf2. E.map (τ f1, f2))"
using f1 uncurry_def E.is_extensional by auto
thus ?thesis by simp
qed
also have "... = τ f1"
proof -
have "A2_B.Dom (τ f1) = (λf2. uncurry F (A1.dom f1, f2))"
proof -
have "A2_B.Dom (τ f1) = A2_B.Map (A2_B.dom (τ f1))"
using f1 A2_B.ide_char A2_B.Map_dom A2_B.dom_char by auto
also have "... = A2_B.Map (F (A1.dom f1))"
using f1 by simp
also have "... = (λf2. uncurry F (A1.dom f1, f2))"
proof
fix f2
interpret F_dom_f1: "functor" A2 B ‹A2_B.Map (F (A1.dom f1))›
using f1 A2_B.ide_char F.preserves_ide by simp
show "A2_B.Map (F (A1.dom f1)) f2 = uncurry F (A1.dom f1, f2)"
using f1 uncurry_def E.map_simp F_dom_f1.is_extensional by auto
qed
finally show ?thesis by auto
qed
moreover have "A2_B.Cod (τ f1) = (λf2. uncurry G (A1.cod f1, f2))"
proof -
have "A2_B.Cod (τ f1) = A2_B.Map (A2_B.cod (τ f1))"
using f1 A2_B.ide_char A2_B.Map_cod A2_B.cod_char by auto
also have "... = A2_B.Map (G (A1.cod f1))"
using f1 by simp
also have "... = (λf2. uncurry G (A1.cod f1, f2))"
proof
fix f2
interpret G_cod_f1: "functor" A2 B ‹A2_B.Map (G (A1.cod f1))›
using f1 A2_B.ide_char G.preserves_ide by simp
show "A2_B.Map (G (A1.cod f1)) f2 = uncurry G (A1.cod f1, f2)"
using f1 uncurry_def E.map_simp G_cod_f1.is_extensional by auto
qed
finally show ?thesis by auto
qed
moreover have "A2_B.Map (τ f1) = (λf2. E.map (τ f1, f2))"
proof
fix f2
have "¬A2.arr f2 ⟹ A2_B.Map (τ f1) f2 = (λf2. E.map (τ f1, f2)) f2"
using f1 A2_B.arrE τ.preserves_reflects_arr natural_transformation.is_extensional
by (metis (no_types, lifting) E.fixing_arr_gives_natural_transformation_1)
moreover have "A2.arr f2 ⟹ A2_B.Map (τ f1) f2 = (λf2. E.map (τ f1, f2)) f2"
using f1 E.map_simp by fastforce
ultimately show "A2_B.Map (τ f1) f2 = (λf2. E.map (τ f1, f2)) f2" by blast
qed
ultimately show ?thesis
using f1 A2_B.MkArr_Map τ.preserves_reflects_arr by metis
qed
finally show ?thesis by auto
qed
ultimately show "curry (uncurry F) (uncurry G) (uncurry τ) f1 = τ f1" by blast
qed
end
locale curried_functor =
currying A1 A2 B +
A1xA2: product_category A1 A2 +
A2_B: functor_category A2 B +
F: binary_functor A1 A2 B F
for A1 :: "'a1 comp" (infixr "⋅⇩A⇩1" 55)
and A2 :: "'a2 comp" (infixr "⋅⇩A⇩2" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and F :: "'a1 * 'a2 ⇒ 'b"
begin
notation A1xA2.comp (infixr "⋅⇩A⇩1⇩x⇩A⇩2" 55)
notation A2_B.comp (infixr "⋅⇩[⇩A⇩2,⇩B⇩]" 55)
notation A1xA2.in_hom ("«_ : _ →⇩A⇩1⇩x⇩A⇩2 _»")
notation A2_B.in_hom ("«_ : _ →⇩[⇩A⇩2⇩,⇩B⇩] _»")
definition map
where "map ≡ curry F F F"
lemma map_simp [simp]:
assumes "A1.arr f1"
shows "map f1 =
A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. F (A1.cod f1, f2)) (λf2. F (f1, f2))"
using assms map_def curry_simp by auto
lemma is_functor:
shows "functor A1 A2_B.comp map"
using F.functor_axioms map_def curry_preserves_functors by simp
end
sublocale curried_functor ⊆ "functor" A1 A2_B.comp map
using is_functor by auto
locale curried_functor' =
A1: category A1 +
A2: category A2 +
A1xA2: product_category A1 A2 +
currying A2 A1 B +
F: binary_functor A1 A2 B F +
A1_B: functor_category A1 B
for A1 :: "'a1 comp" (infixr "⋅⇩A⇩1" 55)
and A2 :: "'a2 comp" (infixr "⋅⇩A⇩2" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and F :: "'a1 * 'a2 ⇒ 'b"
begin
notation A1xA2.comp (infixr "⋅⇩A⇩1⇩x⇩A⇩2" 55)
notation A1_B.comp (infixr "⋅⇩[⇩A⇩1,⇩B⇩]" 55)
notation A1xA2.in_hom ("«_ : _ →⇩A⇩1⇩x⇩A⇩2 _»")
notation A1_B.in_hom ("«_ : _ →⇩[⇩A⇩1⇩,⇩B⇩] _»")
definition map
where "map ≡ curry F.sym F.sym F.sym"
lemma map_simp [simp]:
assumes "A2.arr f2"
shows "map f2 =
A1_B.MkArr (λf1. F (f1, A2.dom f2)) (λf1. F (f1, A2.cod f2)) (λf1. F (f1, f2))"
using assms map_def curry_simp by simp
lemma is_functor:
shows "functor A2 A1_B.comp map"
proof -
interpret A2xA1: product_category A2 A1 ..
interpret F': binary_functor A2 A1 B F.sym
using F.sym_is_binary_functor by simp
have "functor A2xA1.comp B F.sym" ..
thus ?thesis using map_def curry_preserves_functors by simp
qed
end
sublocale curried_functor' ⊆ "functor" A2 A1_B.comp map
using is_functor by auto
end
Theory Yoneda
chapter Yoneda
theory Yoneda
imports DualCategory SetCat FunctorCategory
begin
text‹
This theory defines the notion of a ``hom-functor'' and gives a proof of the Yoneda Lemma.
In traditional developments of category theory based on set theories such as ZFC,
hom-functors are normally defined to be functors into the large category \textbf{Set}
whose objects are of \emph{all} sets and whose arrows are functions between sets.
However, in HOL there does not exist a single ``type of all sets'', so the notion of
the category of \emph{all} sets and functions does not make sense. To work around this,
we consider a more general setting consisting of a category @{term C} together with
a set category @{term S} and a function @{term "φ :: 'c * 'c ⇒ 'c ⇒ 's"} such that
whenever @{term b} and @{term a} are objects of C then @{term "φ (b, a)"} maps
‹C.hom b a› injectively to ‹S.Univ›. We show that these data induce
a binary functor ‹Hom› from ‹Cop×C› to @{term S} in such a way that @{term φ}
is rendered natural in @{term "(b, a)"}. The Yoneda lemma is then proved for the
Yoneda functor determined by ‹Hom›.
›
section "Hom-Functors"
text‹
A hom-functor for a category @{term C} allows us to regard the hom-sets of @{term C}
as objects of a category @{term S} of sets and functions. Any description of a
hom-functor for @{term C} must therefore specify the category @{term S} and provide
some sort of correspondence between arrows of @{term C} and elements of objects of @{term S}.
If we are to think of each hom-set ‹C.hom b a› of ‹C› as corresponding
to an object ‹Hom (b, a)› of @{term S} then at a minimum it ought to be the
case that the correspondence between arrows and elements is bijective between
‹C.hom b a› and ‹Hom (b, a)›. The ‹hom_functor› locale defined
below captures this idea by assuming a set category @{term S} and a function @{term φ}
taking arrows of @{term C} to elements of ‹S.Univ›, such that @{term φ} is injective
on each set ‹C.hom b a›. We show that these data induce a functor ‹Hom›
from ‹Cop×C› to ‹S› in such a way that @{term φ} becomes a natural
bijection between ‹C.hom b a› and ‹Hom (b, a)›.
›
locale hom_functor =
C: category C +
Cop: dual_category C +
CopxC: product_category Cop.comp C +
S: replete_set_category S
for C :: "'c comp" (infixr "⋅" 55)
and S :: "'s comp" (infixr "⋅⇩S" 55)
and φ :: "'c * 'c ⇒ 'c ⇒ 's" +
assumes maps_arr_to_Univ: "C.arr f ⟹ φ (C.dom f, C.cod f) f ∈ S.Univ"
and local_inj: "⟦ C.ide b; C.ide a ⟧ ⟹ inj_on (φ (b, a)) (C.hom b a)"
begin
notation S.in_hom ("«_ : _ →⇩S _»")
notation CopxC.comp (infixr "⊙" 55)
notation CopxC.in_hom ("«_ : _ ⇌ _»")
definition set
where "set ba ≡ φ (fst ba, snd ba) ` C.hom (fst ba) (snd ba)"
lemma set_subset_Univ:
assumes "C.ide b" and "C.ide a"
shows "set (b, a) ⊆ S.Univ"
using assms set_def maps_arr_to_Univ CopxC.ide_char by auto
definition ψ :: "'c * 'c ⇒ 's ⇒ 'c"
where "ψ ba = inv_into (C.hom (fst ba) (snd ba)) (φ ba)"
lemma φ_mapsto:
assumes "C.ide b" and "C.ide a"
shows "φ (b, a) ∈ C.hom b a → set (b, a)"
using assms set_def maps_arr_to_Univ by auto
lemma ψ_mapsto:
assumes "C.ide b" and "C.ide a"
shows "ψ (b, a) ∈ set (b, a) → C.hom b a"
using assms set_def ψ_def local_inj by auto
lemma ψ_φ [simp]:
assumes "«f : b → a»"
shows "ψ (b, a) (φ (b, a) f) = f"
using assms local_inj [of b a] ψ_def by fastforce
lemma φ_ψ [simp]:
assumes "C.ide b" and "C.ide a"
and "x ∈ set (b, a)"
shows "φ (b, a) (ψ (b, a) x) = x"
using assms set_def local_inj ψ_def by auto
lemma ψ_img_set:
assumes "C.ide b" and "C.ide a"
shows "ψ (b, a) ` set (b, a) = C.hom b a"
using assms ψ_def set_def local_inj by auto
text‹
A hom-functor maps each arrow @{term "(g, f)"} of @{term "CopxC"}
to the arrow of the set category @{term[source=true] S} corresponding to the function
that takes an arrow @{term h} of @{term C} to the arrow @{term "C f (C h g)"} of @{term C}
obtained by precomposing with @{term g} and postcomposing with @{term f}.
›
definition map
where "map gf =
(if CopxC.arr gf then
S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf))
(φ (CopxC.cod gf) o (λh. snd gf ⋅ h ⋅ fst gf) o ψ (CopxC.dom gf))
else S.null)"
lemma arr_map:
assumes "CopxC.arr gf"
shows "S.arr (map gf)"
proof -
have "φ (CopxC.cod gf) o (λh. snd gf ⋅ h ⋅ fst gf) o ψ (CopxC.dom gf)
∈ set (CopxC.dom gf) → set (CopxC.cod gf)"
using assms φ_mapsto [of "fst (CopxC.cod gf)" "snd (CopxC.cod gf)"]
ψ_mapsto [of "fst (CopxC.dom gf)" "snd (CopxC.dom gf)"]
by fastforce
thus ?thesis
using assms map_def S.arr_mkArr set_subset_Univ S.card_of_leq by simp
qed
lemma map_ide [simp]:
assumes "C.ide b" and "C.ide a"
shows "map (b, a) = S.mkIde (set (b, a))"
proof -
have "map (b, a) = S.mkArr (set (b, a)) (set (b, a))
(φ (b, a) o (λh. a ⋅ h ⋅ b) o ψ (b, a))"
using assms map_def by auto
also have "... = S.mkArr (set (b, a)) (set (b, a)) (λh. h)"
proof -
have "S.mkArr (set (b, a)) (set (b, a)) (λh. h) = ..."
using assms S.arr_mkArr set_subset_Univ set_def C.comp_arr_dom C.comp_cod_arr
S.card_of_leq S.arr_mkIde
by (intro S.mkArr_eqI', simp, fastforce)
thus ?thesis by auto
qed
also have "... = S.mkIde (set (b, a))"
using assms S.mkIde_as_mkArr set_subset_Univ by simp
finally show ?thesis by auto
qed
lemma set_map:
assumes "C.ide a" and "C.ide b"
shows "S.set (map (b, a)) = set (b, a)"
using assms map_ide S.set_mkIde set_subset_Univ by simp
text‹
The definition does in fact yield a functor.
›
interpretation "functor" CopxC.comp S map
proof
fix gf
assume "¬CopxC.arr gf"
thus "map gf = S.null" using map_def by auto
next
fix gf
assume gf: "CopxC.arr gf"
thus arr: "S.arr (map gf)" using gf arr_map by blast
show "S.dom (map gf) = map (CopxC.dom gf)"
proof -
have "S.dom (map gf) = S.mkArr (set (CopxC.dom gf)) (set (CopxC.dom gf)) (λx. x)"
using gf arr_map map_def S.mkIde_as_mkArr S.arr_mkArr by simp
also have "... = S.mkArr (set (CopxC.dom gf)) (set (CopxC.dom gf))
(φ (CopxC.dom gf) o
(λh. snd (CopxC.dom gf) ⋅ h ⋅ fst (CopxC.dom gf)) o
ψ (CopxC.dom gf))"
using gf set_subset_Univ ψ_mapsto map_def set_def S.card_of_leq S.arr_mkIde S.arr_mkArr
apply (intro S.mkArr_eqI', auto)
by (metis C.comp_arr_dom C.comp_cod_arr C.in_homE)
also have "... = map (CopxC.dom gf)"
using gf map_def C.arr_dom_iff_arr C.arr_cod_iff_arr by simp
finally show ?thesis by auto
qed
show "S.cod (map gf) = map (CopxC.cod gf)"
proof -
have "S.cod (map gf) = S.mkArr (set (CopxC.cod gf)) (set (CopxC.cod gf)) (λx. x)"
using gf map_def arr_map S.mkIde_as_mkArr S.arr_mkArr by simp
also have "... = S.mkArr (set (CopxC.cod gf)) (set (CopxC.cod gf))
(φ (CopxC.cod gf) o
(λh. snd (CopxC.cod gf) ⋅ h ⋅ fst (CopxC.cod gf)) o
ψ (CopxC.cod gf))"
using gf set_subset_Univ ψ_mapsto map_def set_def S.card_of_leq S.arr_mkIde S.arr_mkArr
apply (intro S.mkArr_eqI', auto)
by (metis C.comp_arr_dom C.comp_cod_arr C.in_homE)
also have "... = map (CopxC.cod gf)" using gf map_def by simp
finally show ?thesis by auto
qed
next
fix gf gf'
assume gf': "CopxC.seq gf' gf"
hence seq: "C.arr (fst gf) ∧ C.arr (snd gf) ∧ C.dom (snd gf') = C.cod (snd gf) ∧
C.arr (fst gf') ∧ C.arr (snd gf') ∧ C.dom (fst gf) = C.cod (fst gf')"
by (elim CopxC.seqE C.seqE, auto)
have 0: "S.arr (map (CopxC.comp gf' gf))"
using gf' arr_map by blast
have 1: "map (gf' ⊙ gf) =
S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
(φ (CopxC.cod gf') o (λh. snd (gf' ⊙ gf) ⋅ h ⋅ fst (gf' ⊙ gf))
o ψ (CopxC.dom gf))"
using gf' map_def using CopxC.cod_comp CopxC.dom_comp by auto
also have "... = S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
(φ (CopxC.cod gf') ∘ (λh. snd gf' ⋅ h ⋅ fst gf') ∘ ψ (CopxC.dom gf')
∘
(φ (CopxC.cod gf) ∘ (λh. snd gf ⋅ h ⋅ fst gf) ∘ ψ (CopxC.dom gf)))"
proof (intro S.mkArr_eqI')
show "S.arr (S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
(φ (CopxC.cod gf') ∘ (λh. snd (gf' ⊙ gf) ⋅ h ⋅ fst (gf' ⊙ gf))
∘ ψ (CopxC.dom gf)))"
using 0 1 by simp
show "⋀x. x ∈ set (CopxC.dom gf) ⟹
(φ (CopxC.cod gf') ∘ (λh. snd (gf' ⊙ gf) ⋅ h ⋅ fst (gf' ⊙ gf)) ∘
ψ (CopxC.dom gf)) x =
(φ (CopxC.cod gf') ∘ (λh. snd gf' ⋅ h ⋅ fst gf') ∘ ψ (CopxC.dom gf') ∘
(φ (CopxC.cod gf) ∘ (λh. snd gf ⋅ h ⋅ fst gf) ∘ ψ (CopxC.dom gf))) x"
proof -
fix x
assume "x ∈ set (CopxC.dom gf)"
hence x: "x ∈ set (C.cod (fst gf), C.dom (snd gf))"
using gf' CopxC.seqE by (elim CopxC.seqE, fastforce)
show "(φ (CopxC.cod gf') ∘ (λh. snd (gf' ⊙ gf) ⋅ h ⋅ fst (gf' ⊙ gf)) ∘
ψ (CopxC.dom gf)) x =
(φ (CopxC.cod gf') ∘ (λh. snd gf' ⋅ h ⋅ fst gf') ∘ ψ (CopxC.dom gf') ∘
(φ (CopxC.cod gf) ∘ (λh. snd gf ⋅ h ⋅ fst gf) ∘ ψ (CopxC.dom gf))) x"
proof -
have "(φ (CopxC.cod gf') o (λh. snd (gf' ⊙ gf) ⋅ h ⋅ fst (gf' ⊙ gf))
o ψ (CopxC.dom gf)) x =
φ (CopxC.cod gf') (snd (gf' ⊙ gf) ⋅ ψ (CopxC.dom gf) x ⋅ fst (gf' ⊙ gf))"
by simp
also have "... = φ (CopxC.cod gf')
(((λh. snd gf' ⋅ h ⋅ fst gf') ∘ ψ (CopxC.dom gf') ∘
(φ (CopxC.dom gf') ∘ (λh. snd gf ⋅ h ⋅ fst gf)))
(ψ (CopxC.dom gf) x))"
proof -
have "C.ide (C.cod (fst gf)) ∧ C.ide (C.dom (snd gf))"
using gf' by (elim CopxC.seqE, auto)
hence "«ψ (C.cod (fst gf), C.dom (snd gf)) x : C.cod (fst gf) → C.dom (snd gf)»"
using x ψ_mapsto by auto
hence "«snd gf ⋅ ψ (C.cod (fst gf), C.dom (snd gf)) x ⋅ fst gf :
C.cod (fst gf') → C.dom (snd gf')»"
using x seq by auto
thus ?thesis
using seq ψ_φ C.comp_assoc by auto
qed
also have "... = (φ (CopxC.cod gf') ∘ (λh. snd gf' ⋅ h ⋅ fst gf') ∘ ψ (CopxC.dom gf') ∘
(φ (CopxC.dom gf') ∘ (λh. snd gf ⋅ h ⋅ fst gf) ∘ ψ (CopxC.dom gf)))
x"
by auto
finally show ?thesis using seq by simp
qed
qed
qed
also have "... = map gf' ⋅⇩S map gf"
using seq gf' map_def arr_map [of gf] arr_map [of gf'] S.comp_mkArr by auto
finally show "map (gf' ⊙ gf) = map gf' ⋅⇩S map gf"
using seq gf' by auto
qed
interpretation binary_functor Cop.comp C S map ..
lemma is_binary_functor:
shows "binary_functor Cop.comp C S map" ..
end
sublocale hom_functor ⊆ binary_functor Cop.comp C S map
using is_binary_functor by auto
context hom_functor
begin
text‹
The map @{term φ} determines a bijection between @{term "C.hom b a"} and
@{term "set (b, a)"} which is natural in @{term "(b, a)"}.
›
lemma φ_local_bij:
assumes "C.ide b" and "C.ide a"
shows "bij_betw (φ (b, a)) (C.hom b a) (set (b, a))"
using assms local_inj inj_on_imp_bij_betw set_def by auto
lemma φ_natural:
assumes "C.arr g" and "C.arr f" and "h ∈ C.hom (C.cod g) (C.dom f)"
shows "φ (C.dom g, C.cod f) (f ⋅ h ⋅ g) = S.Fun (map (g, f)) (φ (C.cod g, C.dom f) h)"
proof -
let ?φh = "φ (C.cod g, C.dom f) h"
have φh: "?φh ∈ set (C.cod g, C.dom f)"
using assms φ_mapsto set_def by simp
have gf: "CopxC.arr (g, f)" using assms by simp
have "map (g, f) =
S.mkArr (set (C.cod g, C.dom f)) (set (C.dom g, C.cod f))
(φ (C.dom g, C.cod f) ∘ (λh. f ⋅ h ⋅ g) ∘ ψ (C.cod g, C.dom f))"
using assms map_def by simp
moreover have "S.arr (map (g, f))" using gf by simp
ultimately have
"S.Fun (map (g, f)) =
restrict (φ (C.dom g, C.cod f) ∘ (λh. f ⋅ h ⋅ g) ∘ ψ (C.cod g, C.dom f))
(set (C.cod g, C.dom f))"
using S.Fun_mkArr by simp
hence "S.Fun (map (g, f)) ?φh =
(φ (C.dom g, C.cod f) ∘ (λh. f ⋅ h ⋅ g) ∘ ψ (C.cod g, C.dom f)) ?φh"
using φh by simp
also have "... = φ (C.dom g, C.cod f) (f ⋅ h ⋅ g)"
using assms(3) by simp
finally show ?thesis by auto
qed
lemma Dom_map:
assumes "C.arr g" and "C.arr f"
shows "S.Dom (map (g, f)) = set (C.cod g, C.dom f)"
using assms map_def preserves_arr S.set_mkIde S.arr_mkArr by auto
lemma Cod_map:
assumes "C.arr g" and "C.arr f"
shows "S.Cod (map (g, f)) = set (C.dom g, C.cod f)"
using assms map_def preserves_arr S.set_mkIde S.arr_mkArr by auto
lemma Fun_map:
assumes "C.arr g" and "C.arr f"
shows "S.Fun (map (g, f)) =
restrict (φ (C.dom g, C.cod f) o (λh. f ⋅ h ⋅ g) o ψ (C.cod g, C.dom f))
(set (C.cod g, C.dom f))"
using assms map_def preserves_arr by force
lemma map_simp_1:
assumes "C.arr g" and "C.ide a"
shows "map (g, a) = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
(φ (C.dom g, a) o Cop.comp g o ψ (C.cod g, a))"
proof -
have 1: "map (g, a) = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
(φ (C.dom g, a) o (λh. a ⋅ h ⋅ g) o ψ (C.cod g, a))"
using assms map_def by force
also have "... = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
(φ (C.dom g, a) o Cop.comp g o ψ (C.cod g, a))"
using assms 1 preserves_arr [of "(g, a)"] set_def C.in_homI C.comp_cod_arr
apply (intro S.mkArr_eqI)
apply simp_all
by auto
finally show ?thesis by blast
qed
lemma map_simp_2:
assumes "C.ide b" and "C.arr f"
shows "map (b, f) = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
(φ (b, C.cod f) o C f o ψ (b, C.dom f))"
proof -
have 1: "map (b, f) = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
(φ (b, C.cod f) o (λh. f ⋅ h ⋅ b) o ψ (b, C.dom f))"
using assms map_def by force
also have "... = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
(φ (b, C.cod f) o C f o ψ (b, C.dom f))"
using assms 1 preserves_arr [of "(b, f)"] set_def C.in_homI C.comp_arr_dom
apply (intro S.mkArr_eqI)
apply simp_all
by auto
finally show ?thesis by blast
qed
end
text‹
Every category @{term C} has a hom-functor: take @{term S} to be the replete set category
generated by the arrow type ‹'a› of @{term C} and take @{term "φ (b, a)"} to be the map
‹S.UP :: 'a ⇒ 'a SC.arr›.
›
context category
begin
interpretation Cop: dual_category C ..
interpretation CopxC: product_category Cop.comp C ..
interpretation S: replete_setcat ‹undefined :: 'a› .
lemma has_hom_functor:
shows "hom_functor C (S.comp :: 'a setcat.arr comp) (λ_. S.UP)"
proof
show "⋀f. arr f ⟹ S.UP f ∈ S.Univ"
using S.UP_mapsto by auto
show "⋀b a. ⟦ide b; ide a⟧ ⟹ inj_on S.UP (hom b a)"
by (meson S.inj_UP injD inj_onI)
qed
end
text‹
The locales ‹set_valued_functor› and ‹set_valued_transformation› provide some
abbreviations that are convenient when working with functors and natural transformations
into a set category.
›
locale set_valued_functor =
C: category C +
S: replete_set_category S +
"functor" C S F
for C :: "'c comp"
and S :: "'s comp"
and F :: "'c ⇒ 's"
begin
abbreviation SET :: "'c ⇒ 's set"
where "SET a ≡ S.set (F a)"
abbreviation DOM :: "'c ⇒ 's set"
where "DOM f ≡ S.Dom (F f)"
abbreviation COD :: "'c ⇒ 's set"
where "COD f ≡ S.Cod (F f)"
abbreviation FUN :: "'c ⇒ 's ⇒ 's"
where "FUN f ≡ S.Fun (F f)"
end
locale set_valued_transformation =
C: category C +
S: replete_set_category S +
F: set_valued_functor C S F +
G: set_valued_functor C S G +
natural_transformation C S F G τ
for C :: "'c comp"
and S :: "'s comp"
and F :: "'c ⇒ 's"
and G :: "'c ⇒ 's"
and τ :: "'c ⇒ 's"
begin
abbreviation DOM :: "'c ⇒ 's set"
where "DOM f ≡ S.Dom (τ f)"
abbreviation COD :: "'c ⇒ 's set"
where "COD f ≡ S.Cod (τ f)"
abbreviation FUN :: "'c ⇒ 's ⇒ 's"
where "FUN f ≡ S.Fun (τ f)"
end
section "Yoneda Functors"
text‹
A Yoneda functor is the functor from @{term C} to ‹[Cop, S]› obtained by ``currying''
a hom-functor in its first argument.
›
locale yoneda_functor =
C: category C +
Cop: dual_category C +
CopxC: product_category Cop.comp C +
S: replete_set_category S +
Hom: hom_functor C S φ +
Cop_S: functor_category Cop.comp S +
curried_functor' Cop.comp C S Hom.map
for C :: "'c comp" (infixr "⋅" 55)
and S :: "'s comp" (infixr "⋅⇩S" 55)
and φ :: "'c * 'c ⇒ 'c ⇒ 's"
begin
notation Cop_S.in_hom ("«_ : _ →⇩[⇩C⇩o⇩p⇩,⇩S⇩] _»")
abbreviation ψ
where "ψ ≡ Hom.ψ"
text‹
An arrow of the functor category ‹[Cop, S]› consists of a natural transformation
bundled together with its domain and codomain functors. However, when considering
a Yoneda functor from @{term[source=true] C} to ‹[Cop, S]› we generally are only
interested in the mapping @{term Y} that takes each arrow @{term f} of @{term[source=true] C}
to the corresponding natural transformation @{term "Y f"}. The domain and codomain functors
are then the identity transformations @{term "Y (C.dom f)"} and @{term "Y (C.cod f)"}.
›
definition Y
where "Y f ≡ Cop_S.Map (map f)"
lemma Y_simp [simp]:
assumes "C.arr f"
shows "Y f = (λg. Hom.map (g, f))"
using assms preserves_arr Y_def by simp
lemma Y_ide_is_functor:
assumes "C.ide a"
shows "functor Cop.comp S (Y a)"
using assms Y_def Hom.fixing_ide_gives_functor_2 by force
lemma Y_arr_is_transformation:
assumes "C.arr f"
shows "natural_transformation Cop.comp S (Y (C.dom f)) (Y (C.cod f)) (Y f)"
using assms Y_def [of f] map_def Hom.fixing_arr_gives_natural_transformation_2
preserves_dom preserves_cod by fastforce
lemma Y_ide_arr [simp]:
assumes a: "C.ide a" and "«g : b' → b»"
shows "«Y a g : Hom.map (b, a) →⇩S Hom.map (b', a)»"
and "Y a g =
S.mkArr (Hom.set (b, a)) (Hom.set (b', a)) (φ (b', a) o Cop.comp g o ψ (b, a))"
using assms Hom.map_simp_1 by (fastforce, auto)
lemma Y_arr_ide [simp]:
assumes "C.ide b" and "«f : a → a'»"
shows "«Y f b : Hom.map (b, a) →⇩S Hom.map (b, a')»"
and "Y f b = S.mkArr (Hom.set (b, a)) (Hom.set (b, a')) (φ (b, a') o C f o ψ (b, a))"
using assms apply fastforce
using assms Hom.map_simp_2 by auto
end
locale yoneda_functor_fixed_object =
yoneda_functor C S φ
for C :: "'c comp" (infixr "⋅" 55)
and S :: "'s comp" (infixr "⋅⇩S" 55)
and φ :: "'c * 'c ⇒ 'c ⇒ 's"
and a :: 'c +
assumes ide_a: "C.ide a"
sublocale yoneda_functor_fixed_object ⊆ "functor" Cop.comp S "(Y a)"
using ide_a Y_ide_is_functor by auto
sublocale yoneda_functor_fixed_object ⊆ set_valued_functor Cop.comp S "(Y a)" ..
text‹
The Yoneda lemma states that, given a category @{term C} and a functor @{term F}
from @{term Cop} to a set category @{term S}, for each object @{term a} of @{term C},
the set of natural transformations from the contravariant functor @{term "Y a"}
to @{term F} is in bijective correspondence with the set ‹F.SET a›
of elements of @{term "F a"}.
Explicitly, if @{term e} is an arbitrary element of the set ‹F.SET a›,
then the functions ‹λx. F.FUN (ψ (b, a) x) e› are the components of a
natural transformation from @{term "Y a"} to @{term F}.
Conversely, if @{term τ} is a natural transformation from @{term "Y a"} to @{term F},
then the component @{term "τ b"} of @{term τ} at an arbitrary object @{term b}
is completely determined by the single arrow ‹τ.FUN a (φ (a, a) a)))›,
which is the the element of ‹F.SET a› that corresponds to the image of the
identity @{term a} under the function ‹τ.FUN a›.
Then @{term "τ b"} is the arrow from @{term "Y a b"} to @{term "F b"} corresponding
to the function ‹λx. (F.FUN (ψ (b, a) x) (τ.FUN a (φ (a, a) a)))›
from ‹S.set (Y a b)› to ‹F.SET b›.
The above expressions look somewhat more complicated than the usual versions due to the
need to account for the coercions @{term φ} and @{term ψ}.
›
locale yoneda_lemma =
C: category C +
Cop: dual_category C +
S: replete_set_category S +
F: set_valued_functor Cop.comp S F +
yoneda_functor_fixed_object C S φ a
for C :: "'c comp" (infixr "⋅" 55)
and S :: "'s comp" (infixr "⋅⇩S" 55)
and φ :: "'c * 'c ⇒ 'c ⇒ 's"
and F :: "'c ⇒ 's"
and a :: 'c
begin
text‹
The mapping that evaluates the component @{term "τ a"} at @{term a} of a
natural transformation @{term τ} from @{term Y} to @{term F} on the element
@{term "φ (a, a) a"} of @{term "SET a"}, yielding an element of @{term "F.SET a"}.
›
definition ℰ :: "('c ⇒ 's) ⇒ 's"
where "ℰ τ = S.Fun (τ a) (φ (a, a) a)"
text‹
The mapping that takes an element @{term e} of @{term "F.SET a"} and produces
a map on objects of @{term[source=true] C} whose value at @{term b} is the arrow of
@{term[source=true] S} corresponding to the function
@{term "(λx. F.FUN (ψ (b, a) x) e) ∈ Hom.set (b, a) → F.SET b"}.
›
definition 𝒯o :: "'s ⇒ 'c ⇒ 's"
where "𝒯o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (λx. F.FUN (ψ (b, a) x) e)"
lemma 𝒯o_e_ide:
assumes e: "e ∈ S.set (F a)" and b: "C.ide b"
shows "«𝒯o e b : Y a b →⇩S F b»"
and "𝒯o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (λx. F.FUN (ψ (b, a) x) e)"
proof -
show "𝒯o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (λx. F.FUN (ψ (b, a) x) e)"
using 𝒯o_def by auto
moreover have "(λx. F.FUN (ψ (b, a) x) e) ∈ Hom.set (b, a) → F.SET b"
proof
fix x
assume x: "x ∈ Hom.set (b, a)"
hence "«ψ (b, a) x : b → a»" using assms ide_a Hom.ψ_mapsto by auto
hence "F.FUN (ψ (b, a) x) ∈ F.SET a → F.SET b"
using S.Fun_mapsto [of "F (ψ (b, a) x)"] by fastforce
thus "F.FUN (ψ (b, a) x) e ∈ F.SET b" using e by auto
qed
ultimately show "«𝒯o e b : Y a b →⇩S F b»"
using ide_a b S.mkArr_in_hom [of "Hom.set (b, a)" "F.SET b"] Hom.set_subset_Univ
S.mkIde_set
by auto
qed
text‹
For each @{term "e ∈ F.SET a"}, the mapping @{term "𝒯o e"} gives the components
of a natural transformation @{term 𝒯} from @{term "Y a"} to @{term F}.
›
lemma 𝒯o_e_induces_transformation:
assumes e: "e ∈ S.set (F a)"
shows "transformation_by_components Cop.comp S (Y a) F (𝒯o e)"
proof
fix b :: 'c
assume b: "Cop.ide b"
show "«𝒯o e b : Y a b →⇩S F b»"
using ide_a b e 𝒯o_e_ide by simp
next
fix g :: 'c
assume g: "Cop.arr g"
let ?b = "Cop.dom g"
let ?b' = "Cop.cod g"
show "𝒯o e (Cop.cod g) ⋅⇩S Y a g = F g ⋅⇩S 𝒯o e (Cop.dom g)"
proof -
have 1: "𝒯o e (Cop.cod g) ⋅⇩S Y a g
= S.mkArr (Hom.set (?b, a)) (F.SET ?b')
((λx. F.FUN (ψ (?b', a) x) e)
o (φ (?b', a) o Cop.comp g o ψ (?b, a)))"
proof -
have "S.arr (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
(λs. F.FUN (ψ (Cop.cod g, a) s) e)) ∧
S.dom (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
(λs. F.FUN (ψ (Cop.cod g, a) s) e)) = Y a (Cop.cod g) ∧
S.cod (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
(λs. F.FUN (ψ (Cop.cod g, a) s) e)) = F (Cop.cod g)"
using Cop.cod_char 𝒯o_e_ide [of e ?b'] 𝒯o_e_ide [of e ?b'] e g
by (metis Cop.ide_char Cop.ide_cod S.in_homE)
moreover have "Y a g = S.mkArr (Hom.set (Cop.dom g, a)) (Hom.set (Cop.cod g, a))
(φ (Cop.cod g, a) ∘ Cop.comp g ∘ ψ (Cop.dom g, a))"
using Y_ide_arr [of a g ?b' ?b] ide_a g by auto
ultimately show ?thesis
using ide_a e g Y_ide_arr Cop.cod_char 𝒯o_e_ide
S.comp_mkArr [of "Hom.set (?b, a)" "Hom.set (?b', a)"
"φ (?b', a) o Cop.comp g o ψ (?b, a)"
"F.SET ?b'" "λx. F.FUN (ψ (?b', a) x) e"]
by (metis C.ide_dom Cop.arr_char preserves_arr)
qed
also have "... = S.mkArr (Hom.set (?b, a)) (F.SET ?b')
(F.FUN g o (λx. F.FUN (ψ (?b, a) x) e))"
proof (intro S.mkArr_eqI')
have "(λx. F.FUN (ψ (?b', a) x) e)
o (φ (?b', a) o Cop.comp g o ψ (?b, a)) ∈ Hom.set (?b, a) → F.SET ?b'"
proof -
have "S.arr (S (𝒯o e ?b') (Y a g))"
using ide_a e g 𝒯o_e_ide [of e ?b'] Y_ide_arr(1) [of a "C.dom g" "C.cod g" g]
Cop.ide_char Cop.ide_cod
by blast
thus ?thesis using 1 S.arr_mkArr by simp
qed
thus "S.arr (S.mkArr (Hom.set (?b, a)) (F.SET ?b')
((λx. F.FUN (ψ (?b', a) x) e)
o (φ (?b', a) o Cop.comp g o ψ (?b, a))))"
using ide_a e g Hom.set_subset_Univ S.arr_mkArr by force
show "⋀x. x ∈ Hom.set (?b, a) ⟹
((λx. F.FUN (ψ (?b', a) x) e) o (φ (?b', a) o Cop.comp g o ψ (?b, a))) x
= (F.FUN g o (λx. F.FUN (ψ (?b, a) x) e)) x"
proof -
fix x
assume x: "x ∈ Hom.set (?b, a)"
have "((λx. (F.FUN o ψ (?b', a)) x e)
o (φ (?b', a) o Cop.comp g o ψ (?b, a))) x
= F.FUN (ψ (?b', a) (φ (?b', a) (C (ψ (?b, a) x) g))) e"
by simp
also have "... = (F.FUN g o (F.FUN o ψ (?b, a)) x) e"
proof -
have 1: "«ψ (Cop.dom g, a) x : Cop.dom g → a»"
using ide_a x g Hom.ψ_mapsto [of ?b a] by auto
moreover have "S.seq (F g) (F (ψ (C.cod g, a) x))"
using 1 g by (intro S.seqI', auto)
moreover have "ψ (C.dom g, a) (φ (C.dom g, a) (C (ψ (C.cod g, a) x) g)) =
C (ψ (C.cod g, a) x) g"
using g 1 Hom.ψ_φ [of "C (ψ (?b, a) x) g" ?b' a] by fastforce
ultimately show ?thesis
using assms F.preserves_comp by fastforce
qed
also have "... = (F.FUN g o (λx. F.FUN (ψ (?b, a) x) e)) x" by fastforce
finally show "((λx. F.FUN (ψ (?b', a) x) e)
o (φ (?b', a) o Cop.comp g o ψ (?b, a))) x
= (F.FUN g o (λx. F.FUN (ψ (?b, a) x) e)) x"
by simp
qed
qed
also have "... = F g ⋅⇩S 𝒯o e (Cop.dom g)"
proof -
have "S.arr (F g) ∧ F g = S.mkArr (F.SET ?b) (F.SET ?b') (F.FUN g)"
using g S.mkArr_Fun [of "F g"] by simp
moreover have
"S.arr (𝒯o e ?b) ∧
𝒯o e ?b = S.mkArr (Hom.set (?b, a)) (F.SET ?b) (λx. F.FUN (ψ (?b, a) x) e)"
using e g 𝒯o_e_ide
by (metis C.ide_cod Cop.arr_char Cop.dom_char S.in_homE)
ultimately show ?thesis
using S.comp_mkArr [of "Hom.set (?b, a)" "F.SET ?b" "λx. F.FUN (ψ (?b, a) x) e"
"F.SET ?b'" "F.FUN g"]
by metis
qed
finally show ?thesis by blast
qed
qed
abbreviation 𝒯 :: "'s ⇒ 'c ⇒ 's"
where "𝒯 e ≡ transformation_by_components.map Cop.comp S (Y a) (𝒯o e)"
end
locale yoneda_lemma_fixed_e =
yoneda_lemma C S φ F a
for C :: "'c comp" (infixr "⋅" 55)
and S :: "'s comp" (infixr "⋅⇩S" 55)
and φ :: "'c * 'c ⇒ 'c ⇒ 's"
and F :: "'c ⇒ 's"
and a :: 'c
and e :: 's +
assumes E: "e ∈ F.SET a"
begin
interpretation 𝒯e: transformation_by_components Cop.comp S ‹Y a› F ‹𝒯o e›
using E 𝒯o_e_induces_transformation by auto
lemma natural_transformation_𝒯e:
shows "natural_transformation Cop.comp S (Y a) F (𝒯 e)" ..
lemma 𝒯e_ide:
assumes "Cop.ide b"
shows "S.arr (𝒯 e b)"
and "𝒯 e b = S.mkArr (Hom.set (b, a)) (F.SET b) (λx. F.FUN (ψ (b, a) x) e)"
using assms apply fastforce
using assms 𝒯o_def by auto
end
locale yoneda_lemma_fixed_τ =
yoneda_lemma C S φ F a +
τ: set_valued_transformation Cop.comp S "Y a" F τ
for C :: "'c comp" (infixr "⋅" 55)
and S :: "'s comp" (infixr "⋅⇩S" 55)
and φ :: "'c * 'c ⇒ 'c ⇒ 's"
and F :: "'c ⇒ 's"
and a :: 'c
and τ :: "'c ⇒ 's"
begin
text‹
The key lemma: The component @{term "τ b"} of @{term τ} at an arbitrary object @{term b}
is completely determined by the single element @{term "τ.FUN a (φ (a, a) a) ∈ F.SET a"}.
›
lemma τ_ide:
assumes b: "Cop.ide b"
shows "τ b = S.mkArr (Hom.set (b, a)) (F.SET b)
(λx. (F.FUN (ψ (b, a) x) (τ.FUN a (φ (a, a) a))))"
proof -
let ?φa = "φ (a, a) a"
have φa: "φ (a, a) a ∈ Hom.set (a, a)" using ide_a Hom.φ_mapsto [of a a] by fastforce
have 1: "τ b = S.mkArr (Hom.set (b, a)) (F.SET b) (τ.FUN b)"
using ide_a b S.mkArr_Fun [of "τ b"] Hom.set_map by auto
also have
"... = S.mkArr (Hom.set (b, a)) (F.SET b) (λx. (F.FUN (ψ (b, a) x) (τ.FUN a ?φa)))"
proof (intro S.mkArr_eqI')
show "S.arr (S.mkArr (Hom.set (b, a)) (F.SET b) (τ.FUN b))"
using ide_a b 1 S.mkArr_Fun [of "τ b"] Hom.set_map by auto
show "⋀x. x ∈ Hom.set (b, a) ⟹ τ.FUN b x = (F.FUN (ψ (b, a) x) (τ.FUN a ?φa))"
proof -
fix x
assume x: "x ∈ Hom.set (b, a)"
let ?ψx = "ψ (b, a) x"
have ψx: "«?ψx : b → a»"
using ide_a b x Hom.ψ_mapsto [of b a] by auto
show "τ.FUN b x = (F.FUN (ψ (b, a) x) (τ.FUN a ?φa))"
proof -
have "τ.FUN b x = S.Fun (τ b ⋅⇩S Y a ?ψx) ?φa"
proof -
have "τ.FUN b x = τ.FUN b ((φ (b, a) o Cop.comp ?ψx) a)"
using ide_a b x ψx Hom.φ_ψ
by (metis C.comp_cod_arr C.in_homE C.ide_dom Cop.comp_def comp_apply)
also have "τ.FUN b ((φ (b, a) o Cop.comp ?ψx) a)
= (τ.FUN b o (φ (b, a) o Cop.comp ?ψx o ψ (a, a))) ?φa"
using ide_a b C.ide_in_hom by simp
also have "... = S.Fun (τ b ⋅⇩S Y a ?ψx) ?φa"
proof -
have "S.arr (Y a ?ψx)"
using ide_a ψx preserves_arr by (elim C.in_homE, auto)
moreover have "Y a ?ψx = S.mkArr (Hom.set (a, a)) (SET b)
(φ (b, a) ∘ Cop.comp ?ψx ∘ ψ (a, a))"
using ide_a b ψx preserves_hom Y_ide_arr Hom.set_map C.arrI by auto
moreover have "S.arr (τ b) ∧ τ b = S.mkArr (SET b) (F.SET b) (τ.FUN b)"
using ide_a b S.mkArr_Fun [of "τ b"] by simp
ultimately have
"S.seq (τ b) (Y a ?ψx) ∧
τ b ⋅⇩S Y a ?ψx =
S.mkArr (Hom.set (a, a)) (F.SET b)
(τ.FUN b o (φ (b, a) ∘ Cop.comp ?ψx ∘ ψ (a, a)))"
using 1 S.comp_mkArr S.seqI
by (metis S.cod_mkArr S.dom_mkArr)
thus ?thesis
using ide_a b x Hom.φ_mapsto S.Fun_mkArr by force
qed
finally show ?thesis by auto
qed
also have "... = S.Fun (F ?ψx ⋅⇩S τ a) ?φa"
using ide_a b ψx τ.naturality [of ?ψx] by force
also have "... = F.FUN ?ψx (τ.FUN a ?φa)"
proof -
have "restrict (S.Fun (F ?ψx ⋅⇩S τ a)) (Hom.set (a, a))
= restrict (F.FUN (ψ (b, a) x) o τ.FUN a) (Hom.set (a, a))"
proof -
have
"S.arr (F ?ψx ⋅⇩S τ a) ∧
F ?ψx ⋅⇩S τ a = S.mkArr (Hom.set (a, a)) (F.SET b) (F.FUN ?ψx o τ.FUN a)"
proof
show 1: "S.seq (F ?ψx) (τ a)"
using ψx ide_a τ.preserves_cod F.preserves_dom by (elim C.in_homE, auto)
have "τ a = S.mkArr (Hom.set (a, a)) (F.SET a) (τ.FUN a)"
using ide_a 1 S.mkArr_Fun [of "τ a"] Hom.set_map by auto
moreover have "F ?ψx = S.mkArr (F.SET a) (F.SET b) (F.FUN ?ψx)"
using x ψx 1 S.mkArr_Fun [of "F ?ψx"] by fastforce
ultimately show "F ?ψx ⋅⇩S τ a =
S.mkArr (Hom.set (a, a)) (F.SET b) (F.FUN ?ψx o τ.FUN a)"
using 1 S.comp_mkArr [of "Hom.set (a, a)" "F.SET a" "τ.FUN a"
"F.SET b" "F.FUN ?ψx"]
by (elim S.seqE, auto)
qed
thus ?thesis by force
qed
thus "S.Fun (F (ψ (b, a) x) ⋅⇩S τ a) ?φa = F.FUN ?ψx (τ.FUN a ?φa)"
using ide_a φa restr_eqE [of "S.Fun (F ?ψx ⋅⇩S τ a)"
"Hom.set (a, a)" "F.FUN ?ψx o τ.FUN a"]
by simp
qed
finally show ?thesis by simp
qed
qed
qed
finally show ?thesis by auto
qed
text‹
Consequently, if @{term τ'} is any natural transformation from @{term "Y a"} to @{term F}
that agrees with @{term τ} at @{term a}, then @{term "τ' = τ"}.
›
lemma eqI:
assumes "natural_transformation Cop.comp S (Y a) F τ'" and "τ' a = τ a"
shows "τ' = τ"
proof (intro NaturalTransformation.eqI)
interpret τ': natural_transformation Cop.comp S ‹Y a› F τ' using assms by auto
interpret T': yoneda_lemma_fixed_τ C S φ F a τ' ..
show "natural_transformation Cop.comp S (Y a) F τ" ..
show "natural_transformation Cop.comp S (Y a) F τ'" ..
show "⋀b. Cop.ide b ⟹ τ' b = τ b"
using assms(2) τ_ide T'.τ_ide by simp
qed
end
context yoneda_lemma
begin
text‹
One half of the Yoneda lemma:
The mapping @{term 𝒯} is an injection, with left inverse @{term ℰ},
from the set @{term "F.SET a"} to the set of natural transformations from
@{term "Y a"} to @{term F}.
›
lemma 𝒯_is_injection:
assumes "e ∈ F.SET a"
shows "natural_transformation Cop.comp S (Y a) F (𝒯 e)" and "ℰ (𝒯 e) = e"
proof -
interpret yoneda_lemma_fixed_e C S φ F a e
using assms by (unfold_locales, auto)
interpret 𝒯e: natural_transformation Cop.comp S ‹Y a› F ‹𝒯 e›
using natural_transformation_𝒯e by auto
show "natural_transformation Cop.comp S (Y a) F (𝒯 e)" ..
show "ℰ (𝒯 e) = e"
unfolding ℰ_def
using assms 𝒯e_ide S.Fun_mkArr Hom.φ_mapsto Hom.ψ_φ ide_a
F.preserves_ide S.Fun_ide restrict_apply C.ide_in_hom
by (auto simp add: Pi_iff)
qed
lemma ℰτ_in_Fa:
assumes "natural_transformation Cop.comp S (Y a) F τ"
shows "ℰ τ ∈ F.SET a"
proof -
interpret τ: natural_transformation Cop.comp S ‹Y a› F τ using assms by auto
interpret yoneda_lemma_fixed_τ C S φ F a τ ..
show ?thesis
proof (unfold ℰ_def)
have "S.arr (τ a) ∧ S.Dom (τ a) = Hom.set (a, a) ∧ S.Cod (τ a) = F.SET a"
using ide_a Hom.set_map by auto
hence "τ.FUN a ∈ Hom.set (a, a) → F.SET a"
using S.Fun_mapsto by blast
thus "τ.FUN a (φ (a, a) a) ∈ F.SET a"
using ide_a Hom.φ_mapsto by fastforce
qed
qed
text‹
The other half of the Yoneda lemma:
The mapping @{term 𝒯} is a surjection, with right inverse @{term ℰ},
taking natural transformations from @{term "Y a"} to @{term F}
to elements of @{term "F.SET a"}.
›
lemma 𝒯_is_surjection:
assumes "natural_transformation Cop.comp S (Y a) F τ"
shows "ℰ τ ∈ F.SET a" and "𝒯 (ℰ τ) = τ"
proof -
interpret natural_transformation Cop.comp S ‹Y a› F τ using assms by auto
interpret yoneda_lemma_fixed_τ C S φ F a τ ..
show 1: "ℰ τ ∈ F.SET a" using assms ℰτ_in_Fa by auto
interpret yoneda_lemma_fixed_e C S φ F a ‹ℰ τ›
using 1 by (unfold_locales, auto)
interpret 𝒯e: natural_transformation Cop.comp S ‹Y a› F ‹𝒯 (ℰ τ)›
using natural_transformation_𝒯e by auto
show "𝒯 (ℰ τ) = τ"
proof (intro eqI)
show "natural_transformation Cop.comp S (Y a) F (𝒯 (ℰ τ))" ..
show "𝒯 (ℰ τ) a = τ a"
using ide_a τ_ide [of a] 𝒯e_ide ℰ_def by simp
qed
qed
text‹
The main result.
›
theorem yoneda_lemma:
shows "bij_betw 𝒯 (F.SET a) {τ. natural_transformation Cop.comp S (Y a) F τ}"
using 𝒯_is_injection 𝒯_is_surjection by (intro bij_betwI, auto)
end
text‹
We now consider the special case in which @{term F} is the contravariant
functor @{term "Y a'"}. Then for any @{term e} in ‹Hom.set (a, a')›
we have @{term "𝒯 e = Y (ψ (a, a') e)"}, and @{term 𝒯} is a bijection from
‹Hom.set (a, a')› to the set of natural transformations from @{term "Y a"}
to @{term "Y a'"}. It then follows that that the Yoneda functor @{term Y}
is a fully faithful functor from @{term C} to the functor category ‹[Cop, S]›.
›
locale yoneda_lemma_for_hom =
C: category C +
Cop: dual_category C +
S: replete_set_category S +
yoneda_functor_fixed_object C S φ a +
Ya': yoneda_functor_fixed_object C S φ a' +
yoneda_lemma C S φ "Y a'" a
for C :: "'c comp" (infixr "⋅" 55)
and S :: "'s comp" (infixr "⋅⇩S" 55)
and φ :: "'c * 'c ⇒ 'c ⇒ 's"
and F :: "'c ⇒ 's"
and a :: 'c
and a' :: 'c +
assumes ide_a': "C.ide a'"
begin
text‹
In case @{term F} is the functor @{term "Y a'"}, for any @{term "e ∈ Hom.set (a, a')"}
the induced natural transformation @{term "𝒯 e"} from @{term "Y a"} to @{term "Y a'"}
is just @{term "Y (ψ (a, a') e)"}.
›
lemma 𝒯_equals_Yoψ:
assumes e: "e ∈ Hom.set (a, a')"
shows "𝒯 e = Y (ψ (a, a') e)"
proof -
let ?ψe = "ψ (a, a') e"
have ψe: "«?ψe : a → a'»" using ide_a ide_a' e Hom.ψ_mapsto [of a a'] by auto
interpret Ye: natural_transformation Cop.comp S ‹Y a› ‹Y a'› ‹Y ?ψe›
using Y_arr_is_transformation [of ?ψe] ψe by (elim C.in_homE, auto)
interpret yoneda_lemma_fixed_e C S φ ‹Y a'› a e
using ide_a ide_a' e S.set_mkIde Hom.set_map
by (unfold_locales, simp_all)
interpret 𝒯e: natural_transformation Cop.comp S ‹Y a› ‹Y a'› ‹𝒯 e›
using natural_transformation_𝒯e by auto
interpret yoneda_lemma_fixed_τ C S φ ‹Y a'› a ‹𝒯 e› ..
have "natural_transformation Cop.comp S (Y a) (Y a') (Y ?ψe)" ..
moreover have "natural_transformation Cop.comp S (Y a) (Y a') (𝒯 e)" ..
moreover have "𝒯 e a = Y ?ψe a"
proof -
have 1: "S.arr (𝒯 e a)"
using ide_a e 𝒯e.preserves_reflects_arr by simp
have 2: "𝒯 e a = S.mkArr (Hom.set (a, a)) (Ya'.SET a) (λx. Ya'.FUN (ψ (a, a) x) e)"
using ide_a 𝒯o_def 𝒯e_ide by simp
also have
"... = S.mkArr (Hom.set (a, a)) (Hom.set (a, a')) (φ (a, a') o C ?ψe o ψ (a, a))"
proof (intro S.mkArr_eqI)
show "S.arr (S.mkArr (Hom.set (a, a)) (Ya'.SET a) (λx. Ya'.FUN (ψ (a, a) x) e))"
using ide_a e 1 2 by simp
show "Hom.set (a, a) = Hom.set (a, a)" ..
show 3: "Ya'.SET a = Hom.set (a, a')"
using ide_a ide_a' Y_simp Hom.set_map by simp
show "⋀x. x ∈ Hom.set (a, a) ⟹
Ya'.FUN (ψ (a, a) x) e = (φ (a, a') o C ?ψe o ψ (a, a)) x"
proof -
fix x
assume x: "x ∈ Hom.set (a, a)"
have ψx: "«ψ (a, a) x : a → a»" using ide_a x Hom.ψ_mapsto [of a a] by auto
have "S.arr (Y a' (ψ (a, a) x)) ∧
Y a' (ψ (a, a) x) = S.mkArr (Hom.set (a, a')) (Hom.set (a, a'))
(φ (a, a') ∘ Cop.comp (ψ (a, a) x) ∘ ψ (a, a'))"
using Y_ide_arr ide_a ide_a' ψx by blast
hence "Ya'.FUN (ψ (a, a) x) e = (φ (a, a') ∘ Cop.comp (ψ (a, a) x) ∘ ψ (a, a')) e"
using e 3 S.Fun_mkArr Ya'.preserves_reflects_arr [of "ψ (a, a) x"] by simp
also have "... = (φ (a, a') o C ?ψe o ψ (a, a)) x" by simp
finally show "Ya'.FUN (ψ (a, a) x) e = (φ (a, a') o C ?ψe o ψ (a, a)) x" by auto
qed
qed
also have "... = Y ?ψe a"
using ide_a ide_a' Y_arr_ide ψe by simp
finally show "𝒯 e a = Y ?ψe a" by auto
qed
ultimately show ?thesis using eqI by auto
qed
lemma Y_injective_on_homs:
assumes "«f : a → a'»" and "«f' : a → a'»" and "map f = map f'"
shows "f = f'"
proof -
have "f = ψ (a, a') (φ (a, a') f)"
using assms ide_a Hom.ψ_φ by simp
also have "... = ψ (a, a') (ℰ (𝒯 (φ (a, a') f)))"
using ide_a ide_a' assms(1) 𝒯_is_injection Hom.φ_mapsto Hom.set_map
by (elim C.in_homE, simp add: Pi_iff)
also have "... = ψ (a, a') (ℰ (Y (ψ (a, a') (φ (a, a') f))))"
using assms Hom.φ_mapsto [of a a'] 𝒯_equals_Yoψ [of "φ (a, a') f"] by force
also have "... = ψ (a, a') (ℰ (𝒯 (φ (a, a') f')))"
using assms Hom.φ_mapsto [of a a'] ide_a Hom.ψ_φ Y_def
𝒯_equals_Yoψ [of "φ (a, a') f'"]
by fastforce
also have "... = ψ (a, a') (φ (a, a') f')"
using ide_a ide_a' assms(2) 𝒯_is_injection Hom.φ_mapsto Hom.set_map
by (elim C.in_homE, simp add: Pi_iff)
also have "... = f'"
using assms ide_a Hom.ψ_φ by simp
finally show "f = f'" by auto
qed
lemma Y_surjective_on_homs:
assumes τ: "natural_transformation Cop.comp S (Y a) (Y a') τ"
shows "Y (ψ (a, a') (ℰ τ)) = τ"
using ide_a ide_a' τ 𝒯_is_surjection 𝒯_equals_Yoψ ℰτ_in_Fa Hom.set_map by simp
end
context yoneda_functor
begin
lemma is_faithful_functor:
shows "faithful_functor C Cop_S.comp map"
proof
fix f :: 'c and f' :: 'c
assume par: "C.par f f'" and ff': "map f = map f'"
show "f = f'"
proof -
interpret Ya': yoneda_functor_fixed_object C S φ ‹C.cod f›
using par by (unfold_locales, auto)
interpret yoneda_lemma_for_hom C S φ ‹Y (C.cod f)› ‹C.dom f› ‹C.cod f›
using par by (unfold_locales, auto)
show "f = f'" using par ff' Y_injective_on_homs [of f f'] by fastforce
qed
qed
lemma is_full_functor:
shows "full_functor C Cop_S.comp map"
proof
fix a :: 'c and a' :: 'c and t
assume a: "C.ide a" and a': "C.ide a'"
assume t: "«t : map a →⇩[⇩C⇩o⇩p⇩,⇩S⇩] map a'»"
show "∃e. «e : a → a'» ∧ map e = t"
proof
interpret Ya': yoneda_functor_fixed_object C S φ a'
using a' by (unfold_locales, auto)
interpret yoneda_lemma_for_hom C S φ ‹Y a'› a a'
using a a' by (unfold_locales, auto)
have NT: "natural_transformation Cop.comp S (Y a) (Y a') (Cop_S.Map t)"
using t a' Y_def Cop_S.Map_dom Cop_S.Map_cod Cop_S.dom_char Cop_S.cod_char
Cop_S.in_homE Cop_S.arrE
by metis
hence 1: "ℰ (Cop_S.Map t) ∈ Hom.set (a, a')"
using ℰτ_in_Fa ide_a ide_a' Hom.set_map by simp
moreover have "map (ψ (a, a') (ℰ (Cop_S.Map t))) = t"
proof (intro Cop_S.arr_eqI)
have 2: "«map (ψ (a, a') (ℰ (Cop_S.Map t))) : map a →⇩[⇩C⇩o⇩p⇩,⇩S⇩] map a'»"
using 1 ide_a ide_a' Hom.ψ_mapsto [of a a'] by blast
show "Cop_S.arr t" using t by blast
show "Cop_S.arr (map (ψ (a, a') (ℰ (Cop_S.Map t))))" using 2 by blast
show 3: "Cop_S.Map (map (ψ (a, a') (ℰ (Cop_S.Map t)))) = Cop_S.Map t"
using NT Y_surjective_on_homs Y_def by simp
show 4: "Cop_S.Dom (map (ψ (a, a') (ℰ (Cop_S.Map t)))) = Cop_S.Dom t"
using t 2 natural_transformation_axioms Cop_S.Map_dom by (metis Cop_S.in_homE)
show "Cop_S.Cod (map (ψ (a, a') (ℰ (Cop_S.Map t)))) = Cop_S.Cod t"
using 2 3 4 t Cop_S.Map_cod by (metis Cop_S.in_homE)
qed
ultimately show "«ψ (a, a') (ℰ (Cop_S.Map t)) : a → a'» ∧
map (ψ (a, a') (ℰ (Cop_S.Map t))) = t"
using ide_a ide_a' Hom.ψ_mapsto by auto
qed
qed
end
sublocale yoneda_functor ⊆ faithful_functor C Cop_S.comp map
using is_faithful_functor by auto
sublocale yoneda_functor ⊆ full_functor C Cop_S.comp map using is_full_functor by auto
sublocale yoneda_functor ⊆ fully_faithful_functor C Cop_S.comp map ..
end
Theory Adjunction
chapter Adjunction
theory Adjunction
imports Yoneda
begin
text‹
This theory defines the notions of adjoint functor and adjunction in various
ways and establishes their equivalence.
The notions ``left adjoint functor'' and ``right adjoint functor'' are defined
in terms of universal arrows.
``Meta-adjunctions'' are defined in terms of natural bijections between hom-sets,
where the notion of naturality is axiomatized directly.
``Hom-adjunctions'' formalize the notion of adjunction in terms of natural
isomorphisms of hom-functors.
``Unit-counit adjunctions'' define adjunctions in terms of functors equipped
with unit and counit natural transformations that satisfy the usual
``triangle identities.''
The ‹adjunction› locale is defined as the grand unification of all the
definitions, and includes formulas that connect the data from each of them.
It is shown that each of the definitions induces an interpretation of the
‹adjunction› locale, so that all the definitions are essentially equivalent.
Finally, it is shown that right adjoint functors are unique up to natural
isomorphism.
The reference \cite{Wikipedia-Adjoint-Functors} was useful in constructing this theory.
›
section "Left Adjoint Functor"
text‹
``@{term e} is an arrow from @{term "F x"} to @{term y}.''
›
locale arrow_from_functor =
C: category C +
D: category D +
F: "functor" D C F
for D :: "'d comp" (infixr "⋅⇩D" 55)
and C :: "'c comp" (infixr "⋅⇩C" 55)
and F :: "'d ⇒ 'c"
and x :: 'd
and y :: 'c
and e :: 'c +
assumes arrow: "D.ide x ∧ C.in_hom e (F x) y"
begin
notation C.in_hom ("«_ : _ →⇩C _»")
notation D.in_hom ("«_ : _ →⇩D _»")
text‹
``@{term g} is a @{term[source=true] D}-coextension of @{term f} along @{term e}.''
›
definition is_coext :: "'d ⇒ 'c ⇒ 'd ⇒ bool"
where "is_coext x' f g ≡ «g : x' →⇩D x» ∧ f = e ⋅⇩C F g"
end
text‹
``@{term e} is a terminal arrow from @{term "F x"} to @{term y}.''
›
locale terminal_arrow_from_functor =
arrow_from_functor D C F x y e
for D :: "'d comp" (infixr "⋅⇩D" 55)
and C :: "'c comp" (infixr "⋅⇩C" 55)
and F :: "'d ⇒ 'c"
and x :: 'd
and y :: 'c
and e :: 'c +
assumes is_terminal: "arrow_from_functor D C F x' y f ⟹ (∃!g. is_coext x' f g)"
begin
definition the_coext :: "'d ⇒ 'c ⇒ 'd"
where "the_coext x' f = (THE g. is_coext x' f g)"
lemma the_coext_prop:
assumes "arrow_from_functor D C F x' y f"
shows "«the_coext x' f : x' →⇩D x»" and "f = e ⋅⇩C F (the_coext x' f)"
using assms is_terminal the_coext_def is_coext_def theI2 [of "λg. is_coext x' f g"]
apply metis
using assms is_terminal the_coext_def is_coext_def theI2 [of "λg. is_coext x' f g"]
by metis
lemma the_coext_unique:
assumes "arrow_from_functor D C F x' y f" and "is_coext x' f g"
shows "g = the_coext x' f"
using assms is_terminal the_coext_def the_equality by metis
end
text‹
A left adjoint functor is a functor ‹F: D → C›
that enjoys the following universal coextension property: for each object
@{term y} of @{term C} there exists an object @{term x} of @{term D} and an
arrow ‹e ∈ C.hom (F x) y› such that for any arrow
‹f ∈ C.hom (F x') y› there exists a unique ‹g ∈ D.hom x' x›
such that @{term "f = C e (F g)"}.
›
locale left_adjoint_functor =
C: category C +
D: category D +
"functor" D C F
for D :: "'d comp" (infixr "⋅⇩D" 55)
and C :: "'c comp" (infixr "⋅⇩C" 55)
and F :: "'d ⇒ 'c" +
assumes ex_terminal_arrow: "C.ide y ⟹ (∃x e. terminal_arrow_from_functor D C F x y e)"
begin
notation C.in_hom ("«_ : _ →⇩C _»")
notation D.in_hom ("«_ : _ →⇩D _»")
end
section "Right Adjoint Functor"
text‹
``@{term e} is an arrow from @{term x} to @{term "G y"}.''
›
locale arrow_to_functor =
C: category C +
D: category D +
G: "functor" C D G
for C :: "'c comp" (infixr "⋅⇩C" 55)
and D :: "'d comp" (infixr "⋅⇩D" 55)
and G :: "'c ⇒ 'd"
and x :: 'd
and y :: 'c
and e :: 'd +
assumes arrow: "C.ide y ∧ D.in_hom e x (G y)"
begin
notation C.in_hom ("«_ : _ →⇩C _»")
notation D.in_hom ("«_ : _ →⇩D _»")
text‹
``@{term f} is a @{term[source=true] C}-extension of @{term g} along @{term e}.''
›
definition is_ext :: "'c ⇒ 'd ⇒ 'c ⇒ bool"
where "is_ext y' g f ≡ «f : y →⇩C y'» ∧ g = G f ⋅⇩D e"
end
text‹
``@{term e} is an initial arrow from @{term x} to @{term "G y"}.''
›
locale initial_arrow_to_functor =
arrow_to_functor C D G x y e
for C :: "'c comp" (infixr "⋅⇩C" 55)
and D :: "'d comp" (infixr "⋅⇩D" 55)
and G :: "'c ⇒ 'd"
and x :: 'd
and y :: 'c
and e :: 'd +
assumes is_initial: "arrow_to_functor C D G x y' g ⟹ (∃!f. is_ext y' g f)"
begin
definition the_ext :: "'c ⇒ 'd ⇒ 'c"
where "the_ext y' g = (THE f. is_ext y' g f)"
lemma the_ext_prop:
assumes "arrow_to_functor C D G x y' g"
shows "«the_ext y' g : y →⇩C y'»" and "g = G (the_ext y' g) ⋅⇩D e"
using assms is_initial the_ext_def is_ext_def theI2 [of "λf. is_ext y' g f"]
apply metis
using assms is_initial the_ext_def is_ext_def theI2 [of "λf. is_ext y' g f"]
by metis
lemma the_ext_unique:
assumes "arrow_to_functor C D G x y' g" and "is_ext y' g f"
shows "f = the_ext y' g"
using assms is_initial the_ext_def the_equality by metis
end
text‹
A right adjoint functor is a functor ‹G: C → D›
that enjoys the following universal extension property:
for each object @{term x} of @{term D} there exists an object @{term y} of @{term C}
and an arrow ‹e ∈ D.hom x (G y)› such that for any arrow
‹g ∈ D.hom x (G y')› there exists a unique ‹f ∈ C.hom y y'›
such that @{term "h = D e (G f)"}.
›
locale right_adjoint_functor =
C: category C +
D: category D +
"functor" C D G
for C :: "'c comp" (infixr "⋅⇩C" 55)
and D :: "'d comp" (infixr "⋅⇩D" 55)
and G :: "'c ⇒ 'd" +
assumes initial_arrows_exist: "D.ide x ⟹ (∃y e. initial_arrow_to_functor C D G x y e)"
begin
notation C.in_hom ("«_ : _ →⇩C _»")
notation D.in_hom ("«_ : _ →⇩D _»")
end
section "Various Definitions of Adjunction"
subsection "Meta-Adjunction"
text‹
A ``meta-adjunction'' consists of a functor ‹F: D → C›,
a functor ‹G: C → D›, and for each object @{term x}
of @{term C} and @{term y} of @{term D} a bijection between
‹C.hom (F y) x› to ‹D.hom y (G x)› which is natural in @{term x}
and @{term y}. The naturality is easy to express at the meta-level without having
to resort to the formal baggage of ``set category,'' ``hom-functor,''
and ``natural isomorphism,'' hence the name.
›
locale meta_adjunction =
C: category C +
D: category D +
F: "functor" D C F +
G: "functor" C D G
for C :: "'c comp" (infixr "⋅⇩C" 55)
and D :: "'d comp" (infixr "⋅⇩D" 55)
and F :: "'d ⇒ 'c"
and G :: "'c ⇒ 'd"
and φ :: "'d ⇒ 'c ⇒ 'd"
and ψ :: "'c ⇒ 'd ⇒ 'c" +
assumes φ_in_hom: "⟦ D.ide y; C.in_hom f (F y) x ⟧ ⟹ D.in_hom (φ y f) y (G x)"
and ψ_in_hom: "⟦ C.ide x; D.in_hom g y (G x) ⟧ ⟹ C.in_hom (ψ x g) (F y) x"
and ψ_φ: "⟦ D.ide y; C.in_hom f (F y) x ⟧ ⟹ ψ x (φ y f) = f"
and φ_ψ: "⟦ C.ide x; D.in_hom g y (G x) ⟧ ⟹ φ y (ψ x g) = g"
and φ_naturality: "⟦ C.in_hom f x x'; D.in_hom g y' y; C.in_hom h (F y) x ⟧ ⟹
φ y' (f ⋅⇩C h ⋅⇩C F g) = G f ⋅⇩D φ y h ⋅⇩D g"
begin
notation C.in_hom ("«_ : _ →⇩C _»")
notation D.in_hom ("«_ : _ →⇩D _»")
text‹
The naturality of @{term ψ} is a consequence of the naturality of @{term φ}
and the other assumptions.
›
lemma ψ_naturality:
assumes f: "«f : x →⇩C x'»" and g: "«g : y' →⇩D y»" and h: "«h : y →⇩D G x»"
shows "f ⋅⇩C ψ x h ⋅⇩C F g = ψ x' (G f ⋅⇩D h ⋅⇩D g)"
proof -
have "«f ⋅⇩C ψ x h ⋅⇩C F g : F y' →⇩C x'»"
using f g h ψ_in_hom [of x h] by fastforce
moreover have "«(G f ⋅⇩D h) ⋅⇩D g : y' →⇩D G x'»"
using f g h φ_in_hom by auto
moreover have "ψ x' (φ y' (f ⋅⇩C ψ x h ⋅⇩C F g)) = ψ x' (G f ⋅⇩D φ y (ψ x h) ⋅⇩D g)"
proof -
have "«ψ x h : F y →⇩C x»"
using f h ψ_in_hom by auto
thus ?thesis using f g φ_naturality
by force
qed
ultimately show ?thesis
using f h ψ_φ φ_ψ
by (metis C.arrI C.ide_dom C.in_homE D.arrI D.ide_dom D.in_homE)
qed
lemma respects_natural_isomorphism:
assumes "natural_isomorphism D C F' F τ" and "natural_isomorphism C D G G' μ"
shows "meta_adjunction C D F' G'
(λy f. μ (C.cod f) ⋅⇩D φ y (f ⋅⇩C inverse_transformation.map D C F τ y))
(λx g. ψ x ((inverse_transformation.map C D G' μ x) ⋅⇩D g) ⋅⇩C τ (D.dom g))"
proof -
interpret τ: natural_isomorphism D C F' F τ
using assms(1) by simp
interpret τ': inverse_transformation D C F' F τ
..
interpret μ: natural_isomorphism C D G G' μ
using assms(2) by simp
interpret μ': inverse_transformation C D G G' μ
..
let ?φ' = "λy f. μ (C.cod f) ⋅⇩D φ y (f ⋅⇩C τ'.map y)"
let ?ψ' = "λx g. ψ x (μ'.map x ⋅⇩D g) ⋅⇩C τ (D.dom g)"
show "meta_adjunction C D F' G' ?φ' ?ψ'"
proof
show "⋀y f x. ⟦D.ide y; «f : F' y →⇩C x»⟧
⟹ «μ (C.cod f) ⋅⇩D φ y (f ⋅⇩C τ'.map y) : y →⇩D G' x»"
proof -
fix x y f
assume y: "D.ide y" and f: "«f : F' y →⇩C x»"
show "«μ (C.cod f) ⋅⇩D φ y (f ⋅⇩C τ'.map y) : y →⇩D G' x»"
proof (intro D.comp_in_homI)
show "«μ (C.cod f) : G x →⇩D G' x»"
using f by fastforce
show "«φ y (f ⋅⇩C τ'.map y) : y →⇩D G x»"
using f y φ_in_hom by auto
qed
qed
show "⋀x g y. ⟦C.ide x; «g : y →⇩D G' x»⟧
⟹ «ψ x (μ'.map x ⋅⇩D g) ⋅⇩C τ (D.dom g) : F' y →⇩C x»"
proof -
fix x y g
assume x: "C.ide x" and g: "«g : y →⇩D G' x»"
show "«ψ x (μ'.map x ⋅⇩D g) ⋅⇩C τ (D.dom g) : F' y →⇩C x»"
proof (intro C.comp_in_homI)
show "«τ (D.dom g) : F' y →⇩C F y»"
using g by fastforce
show "«ψ x (μ'.map x ⋅⇩D g) : F y →⇩C x»"
using x g ψ_in_hom by auto
qed
qed
show "⋀y f x. ⟦D.ide y; «f : F' y →⇩C x»⟧
⟹ ψ x (μ'.map x ⋅⇩D μ (C.cod f) ⋅⇩D φ y (f ⋅⇩C τ'.map y)) ⋅⇩C
τ (D.dom (μ (C.cod f) ⋅⇩D φ y (f ⋅⇩C τ'.map y))) =
f"
proof -
fix x y f
assume y: "D.ide y" and f: "«f : F' y →⇩C x»"
have 1: "«φ y (f ⋅⇩C τ'.map y) : y →⇩D G x»"
using f y φ_in_hom by auto
show "ψ x (μ'.map x ⋅⇩D μ (C.cod f) ⋅⇩D φ y (f ⋅⇩C τ'.map y)) ⋅⇩C
τ (D.dom (μ (C.cod f) ⋅⇩D φ y (f ⋅⇩C τ'.map y))) =
f"
proof -
have "ψ x (μ'.map x ⋅⇩D μ (C.cod f) ⋅⇩D φ y (f ⋅⇩C τ'.map y)) ⋅⇩C
τ (D.dom (μ (C.cod f) ⋅⇩D φ y (f ⋅⇩C τ'.map y))) =
ψ x ((μ'.map x ⋅⇩D μ (C.cod f)) ⋅⇩D φ y (f ⋅⇩C τ'.map y)) ⋅⇩C
τ (D.dom (μ (C.cod f) ⋅⇩D φ y (f ⋅⇩C τ'.map y)))"
using D.comp_assoc by simp
also have "... = ψ x (φ y (f ⋅⇩C τ'.map y)) ⋅⇩C τ y"
proof -
have "C.cod f = x"
using f by auto
moreover have "μ'.map x ⋅⇩D μ x = G x"
using f μ'.inverts_components [of x] by force
moreover have "D.dom (μ x ⋅⇩D φ y (f ⋅⇩C τ'.map y)) = y"
using f y 1 by fastforce
ultimately show ?thesis
using f y 1 D.comp_cod_arr by auto
qed
also have "... = f"
using f y ψ_φ C.comp_assoc τ'.inverts_components [of y] C.comp_arr_dom
by fastforce
finally show ?thesis by blast
qed
qed
show "⋀x g y. ⟦C.ide x; «g : y →⇩D G' x»⟧
⟹ μ (C.cod (ψ x (μ'.map x ⋅⇩D g) ⋅⇩C τ (D.dom g))) ⋅⇩D
φ y ((ψ x (μ'.map x ⋅⇩D g) ⋅⇩C τ (D.dom g)) ⋅⇩C τ'.map y) =
g"
proof -
fix x y g
assume x: "C.ide x" and g: "«g : y →⇩D G' x»"
have 1: "«ψ x (μ'.map x ⋅⇩D g) : F y →⇩C x»"
using x g ψ_in_hom by auto
show "μ (C.cod (ψ x (μ'.map x ⋅⇩D g) ⋅⇩C τ (D.dom g))) ⋅⇩D
φ y ((ψ x (μ'.map x ⋅⇩D g) ⋅⇩C τ (D.dom g)) ⋅⇩C τ'.map y) =
g"
proof -
have "μ (C.cod (ψ x (μ'.map x ⋅⇩D g) ⋅⇩C τ (D.dom g))) ⋅⇩D
φ y ((ψ x (μ'.map x ⋅⇩D g) ⋅⇩C τ (D.dom g)) ⋅⇩C τ'.map y) =
μ (C.cod (ψ x (μ'.map x ⋅⇩D g) ⋅⇩C τ (D.dom g))) ⋅⇩D
φ y (ψ x (μ'.map x ⋅⇩D g) ⋅⇩C τ (D.dom g) ⋅⇩C τ'.map y)"
using C.comp_assoc by simp
also have "... = μ x ⋅⇩D φ y (ψ x (μ'.map x ⋅⇩D g))"
proof -
have "D.dom g = y"
using g by auto
moreover have "τ y ⋅⇩C τ'.map y = F y"
using g τ'.inverts_components [of y] by fastforce
moreover have "C.cod (ψ x (μ'.map x ⋅⇩D g) ⋅⇩C τ (D.dom g)) = x"
using g 1 by fastforce
ultimately show ?thesis
using x g 1 C.comp_arr_dom by auto
qed
also have "... = μ x ⋅⇩D μ'.map x ⋅⇩D g"
using x g φ_ψ by auto
also have "... = (μ x ⋅⇩D μ'.map x) ⋅⇩D g"
using D.comp_assoc by simp
also have "... = g"
using x g μ'.inverts_components [of x] D.comp_cod_arr by fastforce
finally show ?thesis by blast
qed
qed
show "⋀f x x' g y' y h. ⟦«f : x →⇩C x'»; «g : y' →⇩D y»; «h : F' y →⇩C x»⟧
⟹ μ (C.cod (f ⋅⇩C h ⋅⇩C F' g)) ⋅⇩D φ y' ((f ⋅⇩C h ⋅⇩C F' g) ⋅⇩C τ'.map y') =
G' f ⋅⇩D (μ (C.cod h) ⋅⇩D φ y (h ⋅⇩C τ'.map y)) ⋅⇩D g"
proof -
fix x y x' y' f g h
assume f: "«f : x →⇩C x'»" and g: "«g : y' →⇩D y»" and h: "«h : F' y →⇩C x»"
show "μ (C.cod (f ⋅⇩C h ⋅⇩C F' g)) ⋅⇩D φ y' ((f ⋅⇩C h ⋅⇩C F' g) ⋅⇩C τ'.map y') =
G' f ⋅⇩D (μ (C.cod h) ⋅⇩D φ y (h ⋅⇩C τ'.map y)) ⋅⇩D g"
proof -
have "μ (C.cod (f ⋅⇩C h ⋅⇩C F' g)) ⋅⇩D φ y' ((f ⋅⇩C h ⋅⇩C F' g) ⋅⇩C τ'.map y') =
μ x' ⋅⇩D φ y' ((f ⋅⇩C h ⋅⇩C F' g) ⋅⇩C τ'.map y')"
using f g h by fastforce
also have "... = μ x' ⋅⇩D φ y' (f ⋅⇩C (h ⋅⇩C τ'.map y) ⋅⇩C F g)"
using g τ'.naturality C.comp_assoc by auto
also have "... = (μ x' ⋅⇩D G f) ⋅⇩D φ y (h ⋅⇩C τ'.map y) ⋅⇩D g"
using f g h φ_naturality [of f x x' g y' y "h ⋅⇩C τ'.map y"] D.comp_assoc
by fastforce
also have "... = (G' f ⋅⇩D μ x) ⋅⇩D φ y (h ⋅⇩C τ'.map y) ⋅⇩D g"
using f μ.naturality by auto
also have "... = G' f ⋅⇩D (μ (C.cod h) ⋅⇩D φ y (h ⋅⇩C τ'.map y)) ⋅⇩D g"
using h D.comp_assoc by auto
finally show ?thesis by blast
qed
qed
qed
qed
end
subsection "Hom-Adjunction"
text‹
The bijection between hom-sets that defines an adjunction can be represented
formally as a natural isomorphism of hom-functors. However, stating the definition
this way is more complex than was the case for ‹meta_adjunction›.
One reason is that we need to have a ``set category'' that is suitable as
a target category for the hom-functors, and since the arrows of the categories
@{term C} and @{term D} will in general have distinct types, we need a set category
that simultaneously embeds both. Another reason is that we simply have to formally
construct the various categories and functors required to express the definition.
This is a good place to point out that I have often included more sublocales
in a locale than are strictly required. The main reason for this is the fact that
the locale system in Isabelle only gives one name to each entity introduced by
a locale: the name that it has in the first locale in which it occurs.
This means that entities that make their first appearance deeply nested in sublocales
will have to be referred to by long qualified names that can be difficult to
understand, or even to discover. To counteract this, I have typically introduced
sublocales before the superlocales that contain them to ensure that the entities
in the sublocales can be referred to by short meaningful (and predictable) names.
In my opinion, though, it would be better if the locale system would make entities
that occur in multiple locales accessible by \emph{all} possible qualified names,
so that the most perspicuous name could be used in any particular context.
›
locale hom_adjunction =
C: category C +
D: category D +
S: replete_set_category S +
Cop: dual_category C +
Dop: dual_category D +
CopxC: product_category Cop.comp C +
DopxD: product_category Dop.comp D +
DopxC: product_category Dop.comp C +
F: "functor" D C F +
G: "functor" C D G +
HomC: hom_functor C S φC +
HomD: hom_functor D S φD +
Fop: dual_functor Dop.comp Cop.comp F +
FopxC: product_functor Dop.comp C Cop.comp C Fop.map C.map +
DopxG: product_functor Dop.comp C Dop.comp D Dop.map G +
Hom_FopxC: composite_functor DopxC.comp CopxC.comp S FopxC.map HomC.map +
Hom_DopxG: composite_functor DopxC.comp DopxD.comp S DopxG.map HomD.map +
Hom_FopxC: set_valued_functor DopxC.comp S Hom_FopxC.map +
Hom_DopxG: set_valued_functor DopxC.comp S Hom_DopxG.map +
Φ: set_valued_transformation DopxC.comp S Hom_FopxC.map Hom_DopxG.map Φ +
Ψ: set_valued_transformation DopxC.comp S Hom_DopxG.map Hom_FopxC.map Ψ +
ΦΨ: inverse_transformations DopxC.comp S Hom_FopxC.map Hom_DopxG.map Φ Ψ
for C :: "'c comp" (infixr "⋅⇩C" 55)
and D :: "'d comp" (infixr "⋅⇩D" 55)
and S :: "'s comp" (infixr "⋅⇩S" 55)
and φC :: "'c * 'c ⇒ 'c ⇒ 's"
and φD :: "'d * 'd ⇒ 'd ⇒ 's"
and F :: "'d ⇒ 'c"
and G :: "'c ⇒ 'd"
and Φ :: "'d * 'c ⇒ 's"
and Ψ :: "'d * 'c ⇒ 's"
begin
notation C.in_hom ("«_ : _ →⇩C _»")
notation D.in_hom ("«_ : _ →⇩D _»")
abbreviation ψC :: "'c * 'c ⇒ 's ⇒ 'c"
where "ψC ≡ HomC.ψ"
abbreviation ψD :: "'d * 'd ⇒ 's ⇒ 'd"
where "ψD ≡ HomD.ψ"
end
subsection "Unit/Counit Adjunction"
text‹
Expressed in unit/counit terms, an adjunction consists of functors
‹F: D → C› and ‹G: C → D›, equipped with natural transformations
‹η: 1 → GF› and ‹ε: FG → 1› satisfying certain ``triangle identities''.
›
locale unit_counit_adjunction =
C: category C +
D: category D +
F: "functor" D C F +
G: "functor" C D G +
GF: composite_functor D C D F G +
FG: composite_functor C D C G F +
FGF: composite_functor D C C F ‹F o G› +
GFG: composite_functor C D D G ‹G o F› +
η: natural_transformation D D D.map ‹G o F› η +
ε: natural_transformation C C ‹F o G› C.map ε +
Fη: natural_transformation D C F ‹F o G o F› ‹F o η› +
ηG: natural_transformation C D G ‹G o F o G› ‹η o G› +
εF: natural_transformation D C ‹F o G o F› F ‹ε o F› +
Gε: natural_transformation C D ‹G o F o G› G ‹G o ε› +
εFoFη: vertical_composite D C F ‹F o G o F› F ‹F o η› ‹ε o F› +
GεoηG: vertical_composite C D G ‹G o F o G› G ‹η o G› ‹G o ε›
for C :: "'c comp" (infixr "⋅⇩C" 55)
and D :: "'d comp" (infixr "⋅⇩D" 55)
and F :: "'d ⇒ 'c"
and G :: "'c ⇒ 'd"
and η :: "'d ⇒ 'd"
and ε :: "'c ⇒ 'c" +
assumes triangle_F: "εFoFη.map = F"
and triangle_G: "GεoηG.map = G"
begin
notation C.in_hom ("«_ : _ →⇩C _»")
notation D.in_hom ("«_ : _ →⇩D _»")
end
lemma unit_determines_counit:
assumes "unit_counit_adjunction C D F G η ε"
and "unit_counit_adjunction C D F G η ε'"
shows "ε = ε'"
proof -
interpret Adj: unit_counit_adjunction C D F G η ε using assms(1) by auto
interpret Adj': unit_counit_adjunction C D F G η ε' using assms(2) by auto
interpret FGFG: composite_functor C D C G ‹F o G o F› ..
interpret FGε: natural_transformation C C ‹(F o G) o (F o G)› ‹F o G› ‹(F o G) o ε›
using Adj.ε.natural_transformation_axioms Adj.FG.natural_transformation_axioms
horizontal_composite Adj.FG.functor_axioms
by fastforce
interpret FηG: natural_transformation C C ‹F o G› ‹F o G o F o G› ‹F o η o G›
using Adj.η.natural_transformation_axioms Adj.Fη.natural_transformation_axioms
Adj.G.natural_transformation_axioms horizontal_composite
by blast
interpret ε'ε: natural_transformation C C ‹F o G o F o G› Adj.C.map ‹ε' o ε›
proof -
have "natural_transformation C C ((F o G) o (F o G)) Adj.C.map (ε' o ε)"
using Adj.ε.natural_transformation_axioms Adj'.ε.natural_transformation_axioms
horizontal_composite Adj.C.is_functor comp_functor_identity
by (metis (no_types, lifting))
thus "natural_transformation C C (F o G o F o G) Adj.C.map (ε' o ε)"
using o_assoc by metis
qed
interpret ε'εoFηG: vertical_composite
C C ‹F o G› ‹F o G o F o G› Adj.C.map ‹F o η o G› ‹ε' o ε› ..
have "ε' = vertical_composite.map C C (F o Adj.GεoηG.map) ε'"
using vcomp_ide_dom [of C C "F o G" Adj.C.map ε'] Adj.triangle_G
by (simp add: Adj'.ε.natural_transformation_axioms)
also have "... = vertical_composite.map C C
(vertical_composite.map C C (F o η o G) (F o G o ε)) ε'"
using whisker_left Adj.F.functor_axioms Adj.Gε.natural_transformation_axioms
Adj.ηG.natural_transformation_axioms o_assoc
by (metis (no_types, lifting))
also have "... = vertical_composite.map C C
(vertical_composite.map C C (F o η o G) (ε' o F o G)) ε"
proof -
have "vertical_composite.map C C
(vertical_composite.map C C (F o η o G) (F o G o ε)) ε'
= vertical_composite.map C C (F o η o G)
(vertical_composite.map C C (F o G o ε) ε')"
using vcomp_assoc
by (metis (no_types, lifting) Adj'.ε.natural_transformation_axioms
FGε.natural_transformation_axioms FηG.natural_transformation_axioms o_assoc)
also have "... = vertical_composite.map C C (F o η o G)
(vertical_composite.map C C (ε' o F o G) ε)"
proof -
have "ε' ∘ Adj.C.map = ε'"
using Adj'.ε.natural_transformation_axioms hcomp_ide_dom by simp
moreover have "Adj.C.map ∘ ε = ε"
using Adj.ε.natural_transformation_axioms hcomp_ide_cod by simp
moreover have "ε' ∘ (F o G) = ε' o F ∘ G" by auto
ultimately show ?thesis
using Adj'.ε.natural_transformation_axioms Adj.ε.natural_transformation_axioms
interchange_spc [of C C "F o G" Adj.C.map ε C "F o G" Adj.C.map ε']
by simp
qed
also have "... = vertical_composite.map C C
(vertical_composite.map C C (F o η o G) (ε' o F o G)) ε"
using vcomp_assoc
by (metis Adj'.εF.natural_transformation_axioms Adj.G.natural_transformation_axioms
Adj.ε.natural_transformation_axioms FηG.natural_transformation_axioms
horizontal_composite)
finally show ?thesis by simp
qed
also have "... = vertical_composite.map C C
(vertical_composite.map D C (F o η) (ε' o F) o G) ε"
using whisker_right Adj'.εF.natural_transformation_axioms
Adj.Fη.natural_transformation_axioms Adj.G.functor_axioms
by metis
also have "... = vertical_composite.map C C (F o G) ε"
using Adj'.triangle_F by simp
also have "... = ε"
using vcomp_ide_cod Adj.ε.natural_transformation_axioms by simp
finally show ?thesis by simp
qed
lemma counit_determines_unit:
assumes "unit_counit_adjunction C D F G η ε"
and "unit_counit_adjunction C D F G η' ε"
shows "η = η'"
proof -
interpret Adj: unit_counit_adjunction C D F G η ε using assms(1) by auto
interpret Adj': unit_counit_adjunction C D F G η' ε using assms(2) by auto
interpret GFGF: composite_functor D C D F ‹G o F o G› ..
interpret GFη: natural_transformation D D ‹G o F› ‹(G o F) o (G o F)› ‹(G o F) o η›
using Adj.η.natural_transformation_axioms Adj.GF.functor_axioms
Adj.GF.natural_transformation_axioms comp_functor_identity horizontal_composite
by (metis (no_types, lifting))
interpret η'GF: natural_transformation D D ‹G o F› ‹(G o F) o (G o F)› ‹η' o (G o F)›
using Adj'.η.natural_transformation_axioms Adj.GF.functor_axioms
Adj.GF.natural_transformation_axioms comp_identity_functor horizontal_composite
by (metis (no_types, lifting))
interpret GεF: natural_transformation D D ‹G o F o G o F› ‹G o F› ‹G o ε o F›
using Adj.ε.natural_transformation_axioms Adj.F.natural_transformation_axioms
Adj.Gε.natural_transformation_axioms horizontal_composite
by blast
interpret η'η: natural_transformation D D Adj.D.map ‹G o F o G o F› ‹η' o η›
proof -
have "natural_transformation D D Adj.D.map ((G o F) o (G o F)) (η' o η)"
using Adj.η.natural_transformation_axioms Adj'.η.natural_transformation_axioms
horizontal_composite Adj.D.natural_transformation_axioms hcomp_ide_cod
by (metis (no_types, lifting))
thus "natural_transformation D D Adj.D.map (G o F o G o F) (η' o η)"
using o_assoc by metis
qed
interpret GεFoη'η: vertical_composite
D D Adj.D.map ‹G o F o G o F› ‹G o F› ‹η' o η› ‹G o ε o F› ..
have "η' = vertical_composite.map D D η' (G o Adj.εFoFη.map)"
using vcomp_ide_cod [of D D Adj.D.map "G o F" η'] Adj.triangle_F
by (simp add: Adj'.η.natural_transformation_axioms)
also have "... = vertical_composite.map D D η'
(vertical_composite.map D D (G o (F o η)) (G o (ε o F)))"
using whisker_left Adj.Fη.natural_transformation_axioms Adj.G.functor_axioms
Adj.εF.natural_transformation_axioms
by fastforce
also have "... = vertical_composite.map D D
(vertical_composite.map D D η' (G o (F o η))) (G o ε o F)"
using vcomp_assoc Adj'.η.natural_transformation_axioms
GFη.natural_transformation_axioms GεF.natural_transformation_axioms o_assoc
by (metis (no_types, lifting))
also have "... = vertical_composite.map D D
(vertical_composite.map D D η (η' o G o F)) (G o ε o F)"
proof -
have "η' ∘ Adj.D.map = η'"
using Adj'.η.natural_transformation_axioms hcomp_ide_dom by simp
moreover have "η' o (G o F) = η' o G o F ∧ G o (F o η) = G o F o η" by auto
ultimately show ?thesis
using interchange_spc [of D D Adj.D.map "G o F" η D Adj.D.map "G o F" η']
Adj.η.natural_transformation_axioms Adj'.η.natural_transformation_axioms
by simp
qed
also have "... = vertical_composite.map D D η
(vertical_composite.map D D (η' o G o F) (G o ε o F))"
using vcomp_assoc
by (metis (no_types, lifting) Adj.η.natural_transformation_axioms
GεF.natural_transformation_axioms η'GF.natural_transformation_axioms o_assoc)
also have "... = vertical_composite.map D D η
(vertical_composite.map C D (η' o G) (G o ε) o F)"
using whisker_right Adj'.ηG.natural_transformation_axioms Adj.F.functor_axioms
Adj.Gε.natural_transformation_axioms
by fastforce
also have "... = vertical_composite.map D D η (G o F)"
using Adj'.triangle_G by simp
also have "... = η"
using vcomp_ide_dom Adj.GF.functor_axioms Adj.η.natural_transformation_axioms by simp
finally show ?thesis by simp
qed
subsection "Adjunction"
text‹
The grand unification of everything to do with an adjunction.
›
locale adjunction =
C: category C +
D: category D +
S: replete_set_category S +
Cop: dual_category C +
Dop: dual_category D +
CopxC: product_category Cop.comp C +
DopxD: product_category Dop.comp D +
DopxC: product_category Dop.comp C +
idDop: identity_functor Dop.comp +
HomC: hom_functor C S φC +
HomD: hom_functor D S φD +
F: left_adjoint_functor D C F +
G: right_adjoint_functor C D G +
GF: composite_functor D C D F G +
FG: composite_functor C D C G F +
FGF: composite_functor D C C F FG.map +
GFG: composite_functor C D D G GF.map +
Fop: dual_functor Dop.comp Cop.comp F +
FopxC: product_functor Dop.comp C Cop.comp C Fop.map C.map +
DopxG: product_functor Dop.comp C Dop.comp D Dop.map G +
Hom_FopxC: composite_functor DopxC.comp CopxC.comp S FopxC.map HomC.map +
Hom_DopxG: composite_functor DopxC.comp DopxD.comp S DopxG.map HomD.map +
Hom_FopxC: set_valued_functor DopxC.comp S Hom_FopxC.map +
Hom_DopxG: set_valued_functor DopxC.comp S Hom_DopxG.map +
η: natural_transformation D D D.map GF.map η +
ε: natural_transformation C C FG.map C.map ε +
Fη: natural_transformation D C F ‹F o G o F› ‹F o η› +
ηG: natural_transformation C D G ‹G o F o G› ‹η o G› +
εF: natural_transformation D C ‹F o G o F› F ‹ε o F› +
Gε: natural_transformation C D ‹G o F o G› G ‹G o ε› +
εFoFη: vertical_composite D C F FGF.map F ‹F o η› ‹ε o F› +
GεoηG: vertical_composite C D G GFG.map G ‹η o G› ‹G o ε› +
φψ: meta_adjunction C D F G φ ψ +
ηε: unit_counit_adjunction C D F G η ε +
ΦΨ: hom_adjunction C D S φC φD F G Φ Ψ
for C :: "'c comp" (infixr "⋅⇩C" 55)
and D :: "'d comp" (infixr "⋅⇩D" 55)
and S :: "'s comp" (infixr "⋅⇩S" 55)
and φC :: "'c * 'c ⇒ 'c ⇒ 's"
and φD :: "'d * 'd ⇒ 'd ⇒ 's"
and F :: "'d ⇒ 'c"
and G :: "'c ⇒ 'd"
and φ :: "'d ⇒ 'c ⇒ 'd"
and ψ :: "'c ⇒ 'd ⇒ 'c"
and η :: "'d ⇒ 'd"
and ε :: "'c ⇒ 'c"
and Φ :: "'d * 'c ⇒ 's"
and Ψ :: "'d * 'c ⇒ 's" +
assumes φ_in_terms_of_η: "⟦ D.ide y; «f : F y →⇩C x» ⟧ ⟹ φ y f = G f ⋅⇩D η y"
and ψ_in_terms_of_ε: "⟦ C.ide x; «g : y →⇩D G x» ⟧ ⟹ ψ x g = ε x ⋅⇩C F g"
and η_in_terms_of_φ: "D.ide y ⟹ η y = φ y (F y)"
and ε_in_terms_of_ψ: "C.ide x ⟹ ε x = ψ x (G x)"
and φ_in_terms_of_Φ: "⟦ D.ide y; «f : F y →⇩C x» ⟧ ⟹
φ y f = (ΦΨ.ψD (y, G x) o S.Fun (Φ (y, x)) o φC (F y, x)) f"
and ψ_in_terms_of_Ψ: "⟦ C.ide x; «g : y →⇩D G x» ⟧ ⟹
ψ x g = (ΦΨ.ψC (F y, x) o S.Fun (Ψ (y, x)) o φD (y, G x)) g"
and Φ_in_terms_of_φ:
"⟦ C.ide x; D.ide y ⟧ ⟹
Φ (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(φD (y, G x) o φ y o ΦΨ.ψC (F y, x))"
and Ψ_in_terms_of_ψ:
"⟦ C.ide x; D.ide y ⟧ ⟹
Ψ (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(φC (F y, x) o ψ x o ΦΨ.ψD (y, G x))"
section "Meta-Adjunctions Induce Unit/Counit Adjunctions"
context meta_adjunction
begin
interpretation GF: composite_functor D C D F G ..
interpretation FG: composite_functor C D C G F ..
interpretation FGF: composite_functor D C C F FG.map ..
interpretation GFG: composite_functor C D D G GF.map ..
definition ηo :: "'d ⇒ 'd"
where "ηo y = φ y (F y)"
lemma ηo_in_hom:
assumes "D.ide y"
shows "«ηo y : y →⇩D G (F y)»"
using assms D.ide_in_hom ηo_def φ_in_hom by force
lemma φ_in_terms_of_ηo:
assumes "D.ide y" and "«f : F y →⇩C x»"
shows "φ y f = G f ⋅⇩D ηo y"
proof (unfold ηo_def)
have 1: "«F y : F y →⇩C F y»"
using assms(1) D.ide_in_hom by blast
hence "φ y (F y) = φ y (F y) ⋅⇩D y"
by (metis assms(1) D.in_homE φ_in_hom D.comp_arr_dom)
thus "φ y f = G f ⋅⇩D φ y (F y)"
using assms 1 D.ide_in_hom by (metis C.comp_arr_dom C.in_homE φ_naturality)
qed
lemma φ_F_char:
assumes "«g : y' →⇩D y»"
shows "φ y' (F g) = ηo y ⋅⇩D g"
using assms ηo_def φ_in_hom [of y "F y" "F y"]
D.comp_cod_arr [of "D (φ y (F y)) g" "G (F y)"]
φ_naturality [of "F y" "F y" "F y" g y' y "F y"]
by (metis D.arr_cod D.cod_cod D.comp_in_homI' D.ide_char' D.ide_in_hom D.in_homE
F.is_natural_2 F.preserves_hom)
interpretation η: transformation_by_components D D D.map GF.map ηo
proof
show "⋀a. D.ide a ⟹ «ηo a : D.map a →⇩D GF.map a»"
using ηo_def φ_in_hom D.ide_in_hom by force
fix f
assume f: "D.arr f"
show "ηo (D.cod f) ⋅⇩D D.map f = GF.map f ⋅⇩D ηo (D.dom f)"
using f φ_F_char [of "D.map f" "D.dom f" "D.cod f"]
φ_in_terms_of_ηo [of "D.dom f" "F f" "F (D.cod f)"]
by force
qed
lemma η_map_simp:
assumes "D.ide y"
shows "η.map y = φ y (F y)"
using assms η.map_simp_ide ηo_def by simp
definition εo :: "'c ⇒ 'c"
where "εo x = ψ x (G x)"
lemma εo_in_hom:
assumes "C.ide x"
shows "«εo x : F (G x) →⇩C x»"
using assms C.ide_in_hom εo_def ψ_in_hom by force
lemma ψ_in_terms_of_εo:
assumes "C.ide x" and "«g : y →⇩D G x»"
shows "ψ x g = εo x ⋅⇩C F g"
proof -
have "εo x ⋅⇩C F g = x ⋅⇩C ψ x (G x) ⋅⇩C F g"
using assms εo_def ψ_in_hom [of x "G x" "G x"]
C.comp_cod_arr [of "ψ x (G x) ⋅⇩C F g" x]
by fastforce
also have "... = ψ x (G x ⋅⇩D G x ⋅⇩D g)"
using assms ψ_naturality [of x x x g y "G x" "G x"] by force
also have "... = ψ x g"
using assms D.comp_cod_arr by fastforce
finally show ?thesis by simp
qed
lemma ψ_G_char:
assumes "«f: x →⇩C x'»"
shows "ψ x' (G f) = f ⋅⇩C εo x"
proof (unfold εo_def)
have 0: "C.ide x ∧ C.ide x'" using assms by auto
thus "ψ x' (G f) = f ⋅⇩C ψ x (G x)"
using 0 assms ψ_naturality ψ_in_hom [of x "G x" "G x"] G.preserves_hom εo_def
ψ_in_terms_of_εo G.is_natural_1 C.ide_in_hom
by (metis C.arrI C.in_homE)
qed
interpretation ε: transformation_by_components C C FG.map C.map εo
apply unfold_locales
using εo_in_hom
apply simp
using ψ_G_char ψ_in_terms_of_εo
by (metis C.arr_iff_in_hom C.ide_cod C.map_simp G.preserves_hom comp_apply)
lemma ε_map_simp:
assumes "C.ide x"
shows "ε.map x = ψ x (G x)"
using assms εo_def by simp
interpretation FD: composite_functor D D C D.map F ..
interpretation CF: composite_functor D C C F C.map ..
interpretation GC: composite_functor C C D C.map G ..
interpretation DG: composite_functor C D D G D.map ..
interpretation Fη: natural_transformation D C F ‹F o G o F› ‹F o η.map›
proof -
have "natural_transformation D C F (F o (G o F)) (F o η.map)"
using η.natural_transformation_axioms F.natural_transformation_axioms
horizontal_composite
by fastforce
thus "natural_transformation D C F (F o G o F) (F o η.map)"
using o_assoc by metis
qed
interpretation εF: natural_transformation D C ‹F o G o F› F ‹ε.map o F›
using ε.natural_transformation_axioms F.natural_transformation_axioms
horizontal_composite
by fastforce
interpretation ηG: natural_transformation C D G ‹G o F o G› ‹η.map o G›
using η.natural_transformation_axioms G.natural_transformation_axioms
horizontal_composite
by fastforce
interpretation Gε: natural_transformation C D ‹G o F o G› G ‹G o ε.map›
proof -
have "natural_transformation C D (G o (F o G)) G (G o ε.map)"
using ε.natural_transformation_axioms G.natural_transformation_axioms
horizontal_composite
by fastforce
thus "natural_transformation C D (G o F o G) G (G o ε.map)"
using o_assoc by metis
qed
interpretation εFoFη: vertical_composite D C F ‹F o G o F› F ‹F o η.map› ‹ε.map o F›
..
interpretation GεoηG: vertical_composite C D G ‹G o F o G› G ‹η.map o G› ‹G o ε.map›
..
lemma unit_counit_F:
assumes "D.ide y"
shows "F y = εo (F y) ⋅⇩C F (ηo y)"
using assms ψ_in_terms_of_εo ηo_def ψ_φ ηo_in_hom F.preserves_ide C.ide_in_hom by metis
lemma unit_counit_G:
assumes "C.ide x"
shows "G x = G (εo x) ⋅⇩D ηo (G x)"
using assms φ_in_terms_of_ηo εo_def φ_ψ εo_in_hom G.preserves_ide D.ide_in_hom by metis
lemma induces_unit_counit_adjunction':
shows "unit_counit_adjunction C D F G η.map ε.map"
proof
show "εFoFη.map = F"
using εFoFη.is_natural_transformation εFoFη.map_simp_ide unit_counit_F
F.natural_transformation_axioms
by (intro NaturalTransformation.eqI, auto)
show "GεoηG.map = G"
using GεoηG.is_natural_transformation GεoηG.map_simp_ide unit_counit_G
G.natural_transformation_axioms
by (intro NaturalTransformation.eqI, auto)
qed
definition η :: "'d ⇒ 'd" where "η ≡ η.map"
definition ε :: "'c ⇒ 'c" where "ε ≡ ε.map"
theorem induces_unit_counit_adjunction:
shows "unit_counit_adjunction C D F G η ε"
unfolding η_def ε_def
using induces_unit_counit_adjunction' by simp
lemma η_is_natural_transformation:
shows "natural_transformation D D D.map GF.map η"
unfolding η_def ..
lemma ε_is_natural_transformation:
shows "natural_transformation C C FG.map C.map ε"
unfolding ε_def ..
text‹
From the defined @{term η} and @{term ε} we can recover the original @{term φ} and @{term ψ}.
›
lemma φ_in_terms_of_η:
assumes "D.ide y" and "«f : F y →⇩C x»"
shows "φ y f = G f ⋅⇩D η y"
using assms η_def by (simp add: φ_in_terms_of_ηo)
lemma ψ_in_terms_of_ε:
assumes "C.ide x" and "«g : y →⇩D G x»"
shows "ψ x g = ε x ⋅⇩C F g"
using assms ε_def by (simp add: ψ_in_terms_of_εo)
end
section "Meta-Adjunctions Induce Left and Right Adjoint Functors"
context meta_adjunction
begin
interpretation unit_counit_adjunction C D F G η ε
using induces_unit_counit_adjunction η_def ε_def by auto
lemma has_terminal_arrows_from_functor:
assumes x: "C.ide x"
shows "terminal_arrow_from_functor D C F (G x) x (ε x)"
and "⋀y' f. arrow_from_functor D C F y' x f
⟹ terminal_arrow_from_functor.the_coext D C F (G x) (ε x) y' f = φ y' f"
proof -
interpret εx: arrow_from_functor D C F ‹G x› x ‹ε x›
apply unfold_locales
using x ε.preserves_hom G.preserves_ide by auto
have 1: "⋀y' f. arrow_from_functor D C F y' x f ⟹
εx.is_coext y' f (φ y' f) ∧ (∀g'. εx.is_coext y' f g' ⟶ g' = φ y' f)"
proof
fix y' :: 'd and f :: 'c
assume f: "arrow_from_functor D C F y' x f"
show "εx.is_coext y' f (φ y' f)"
using f x ε_def φ_in_hom ψ_φ ψ_in_terms_of_ε εx.is_coext_def arrow_from_functor.arrow
by metis
show "∀g'. εx.is_coext y' f g' ⟶ g' = φ y' f"
using εo_def ψ_in_terms_of_εo x ε_map_simp φ_ψ εx.is_coext_def ε_def by simp
qed
interpret εx: terminal_arrow_from_functor D C F ‹G x› x ‹ε x›
apply unfold_locales using 1 by blast
show "terminal_arrow_from_functor D C F (G x) x (ε x)" ..
show "⋀y' f. arrow_from_functor D C F y' x f ⟹ εx.the_coext y' f = φ y' f"
using 1 εx.the_coext_def by auto
qed
lemma has_left_adjoint_functor:
shows "left_adjoint_functor D C F"
apply unfold_locales using has_terminal_arrows_from_functor by auto
lemma has_initial_arrows_to_functor:
assumes y: "D.ide y"
shows "initial_arrow_to_functor C D G y (F y) (η y)"
and "⋀x' g. arrow_to_functor C D G y x' g ⟹
initial_arrow_to_functor.the_ext C D G (F y) (η y) x' g = ψ x' g"
proof -
interpret ηy: arrow_to_functor C D G y ‹F y› ‹η y›
apply unfold_locales using y by auto
have 1: "⋀x' g. arrow_to_functor C D G y x' g ⟹
ηy.is_ext x' g (ψ x' g) ∧ (∀f'. ηy.is_ext x' g f' ⟶ f' = ψ x' g)"
proof
fix x' :: 'c and g :: 'd
assume g: "arrow_to_functor C D G y x' g"
show "ηy.is_ext x' g (ψ x' g)"
using g y ψ_in_hom φ_ψ φ_in_terms_of_η ηy.is_ext_def arrow_to_functor.arrow η_def
by metis
show "∀f'. ηy.is_ext x' g f' ⟶ f' = ψ x' g"
using y ηo_def φ_in_terms_of_ηo η_map_simp ψ_φ ηy.is_ext_def η_def by simp
qed
interpret ηy: initial_arrow_to_functor C D G y ‹F y› ‹η y›
apply unfold_locales using 1 by blast
show "initial_arrow_to_functor C D G y (F y) (η y)" ..
show "⋀x' g. arrow_to_functor C D G y x' g ⟹ ηy.the_ext x' g = ψ x' g"
using 1 ηy.the_ext_def by auto
qed
lemma has_right_adjoint_functor:
shows "right_adjoint_functor C D G"
apply unfold_locales using has_initial_arrows_to_functor by auto
end
section "Unit/Counit Adjunctions Induce Meta-Adjunctions"
context unit_counit_adjunction
begin
definition φ :: "'d ⇒ 'c ⇒ 'd"
where "φ y h = G h ⋅⇩D η y"
definition ψ :: "'c ⇒ 'd ⇒ 'c"
where "ψ x h = ε x ⋅⇩C F h"
interpretation meta_adjunction C D F G φ ψ
proof
fix x :: 'c and y :: 'd and f :: 'c
assume y: "D.ide y" and f: "«f : F y →⇩C x»"
show 0: "«φ y f : y →⇩D G x»"
using f y G.preserves_hom η.preserves_hom φ_def D.ide_in_hom by auto
show "ψ x (φ y f) = f"
proof -
have "ψ x (φ y f) = (ε x ⋅⇩C F (G f)) ⋅⇩C F (η y)"
using y f φ_def ψ_def C.comp_assoc by auto
also have "... = (f ⋅⇩C ε (F y)) ⋅⇩C F (η y)"
using y f ε.naturality by auto
also have "... = f"
using y f εFoFη.map_simp_2 triangle_F C.comp_arr_dom D.ide_in_hom C.comp_assoc
by fastforce
finally show ?thesis by auto
qed
next
fix x :: 'c and y :: 'd and g :: 'd
assume x: "C.ide x" and g: "«g : y →⇩D G x»"
show "«ψ x g : F y →⇩C x»" using g x ψ_def by fastforce
show "φ y (ψ x g) = g"
proof -
have "φ y (ψ x g) = (G (ε x) ⋅⇩D η (G x)) ⋅⇩D g"
using g x φ_def ψ_def η.naturality [of g] D.comp_assoc by auto
also have "... = g"
using x g triangle_G D.comp_ide_arr GεoηG.map_simp_ide by auto
finally show ?thesis by auto
qed
next
fix f :: 'c and g :: 'd and h :: 'c and x :: 'c and x' :: 'c and y :: 'd and y' :: 'd
assume f: "«f : x →⇩C x'»" and g: "«g : y' →⇩D y»" and h: "«h : F y →⇩C x»"
show "φ y' (f ⋅⇩C h ⋅⇩C F g) = G f ⋅⇩D φ y h ⋅⇩D g"
using φ_def f g h η.naturality D.comp_assoc by fastforce
qed
theorem induces_meta_adjunction:
shows "meta_adjunction C D F G φ ψ" ..
text‹
From the defined @{term φ} and @{term ψ} we can recover the original @{term η} and @{term ε}.
›
lemma η_in_terms_of_φ:
assumes "D.ide y"
shows "η y = φ y (F y)"
using assms φ_def D.comp_cod_arr by auto
lemma ε_in_terms_of_ψ:
assumes "C.ide x"
shows "ε x = ψ x (G x)"
using assms ψ_def C.comp_arr_dom by auto
end
section "Left and Right Adjoint Functors Induce Meta-Adjunctions"
text‹
A left adjoint functor induces a meta-adjunction, modulo the choice of a
right adjoint and counit.
›
context left_adjoint_functor
begin
definition Go :: "'c ⇒ 'd"
where "Go a = (SOME b. ∃e. terminal_arrow_from_functor D C F b a e)"
definition εo :: "'c ⇒ 'c"
where "εo a = (SOME e. terminal_arrow_from_functor D C F (Go a) a e)"
lemma Go_εo_terminal:
assumes "∃b e. terminal_arrow_from_functor D C F b a e"
shows "terminal_arrow_from_functor D C F (Go a) a (εo a)"
using assms Go_def εo_def
someI_ex [of "λb. ∃e. terminal_arrow_from_functor D C F b a e"]
someI_ex [of "λe. terminal_arrow_from_functor D C F (Go a) a e"]
by simp
text‹
The right adjoint @{term G} to @{term F} takes each arrow @{term f} of
@{term[source=true] C} to the unique @{term[source=true] D}-coextension of
@{term "C f (εo (C.dom f))"} along @{term "εo (C.cod f)"}.
›
definition G :: "'c ⇒ 'd"
where "G f = (if C.arr f then
terminal_arrow_from_functor.the_coext D C F (Go (C.cod f)) (εo (C.cod f))
(Go (C.dom f)) (f ⋅⇩C εo (C.dom f))
else D.null)"
lemma G_ide:
assumes "C.ide x"
shows "G x = Go x"
proof -
interpret terminal_arrow_from_functor D C F ‹Go x› x ‹εo x›
using assms ex_terminal_arrow Go_εo_terminal by blast
have 1: "arrow_from_functor D C F (Go x) x (εo x)" ..
have "is_coext (Go x) (εo x) (Go x)"
using arrow is_coext_def C.in_homE C.comp_arr_dom by auto
hence "Go x = the_coext (Go x) (εo x)" using 1 the_coext_unique by blast
moreover have "εo x = C x (εo (C.dom x))"
using assms arrow C.comp_ide_arr C.seqI' C.ide_in_hom C.in_homE by metis
ultimately show ?thesis using assms G_def C.cod_dom C.ide_in_hom C.in_homE by metis
qed
lemma G_is_functor:
shows "functor C D G"
proof
fix f :: 'c
assume "¬C.arr f"
thus "G f = D.null" using G_def by auto
next
fix f :: 'c
assume f: "C.arr f"
let ?x = "C.dom f"
let ?x' = "C.cod f"
interpret xε: terminal_arrow_from_functor D C F ‹Go ?x› ‹?x› ‹εo ?x›
using f ex_terminal_arrow Go_εo_terminal by simp
interpret x'ε: terminal_arrow_from_functor D C F ‹Go ?x'› ‹?x'› ‹εo ?x'›
using f ex_terminal_arrow Go_εo_terminal by simp
have 1: "arrow_from_functor D C F (Go ?x) ?x' (C f (εo ?x))"
using f xε.arrow by (unfold_locales, auto)
have "G f = x'ε.the_coext (Go ?x) (C f (εo ?x))" using f G_def by simp
hence Gf: "«G f : Go ?x →⇩D Go ?x'» ∧ f ⋅⇩C εo ?x = εo ?x' ⋅⇩C F (G f)"
using 1 x'ε.the_coext_prop by simp
show "D.arr (G f)" using Gf by auto
show "D.dom (G f) = G ?x" using f Gf G_ide by auto
show "D.cod (G f) = G ?x'" using f Gf G_ide by auto
next
fix f f' :: 'c
assume ff': "C.arr (C f' f)"
have f: "C.arr f" using ff' by auto
let ?x = "C.dom f"
let ?x' = "C.cod f"
let ?x'' = "C.cod f'"
interpret xε: terminal_arrow_from_functor D C F ‹Go ?x› ‹?x› ‹εo ?x›
using f ex_terminal_arrow Go_εo_terminal by simp
interpret x'ε: terminal_arrow_from_functor D C F ‹Go ?x'› ‹?x'› ‹εo ?x'›
using f ex_terminal_arrow Go_εo_terminal by simp
interpret x''ε: terminal_arrow_from_functor D C F ‹Go ?x''› ‹?x''› ‹εo ?x''›
using ff' ex_terminal_arrow Go_εo_terminal by auto
have 1: "arrow_from_functor D C F (Go ?x) ?x' (f ⋅⇩C εo ?x)"
using f xε.arrow by (unfold_locales, auto)
have 2: "arrow_from_functor D C F (Go ?x') ?x'' (f' ⋅⇩C εo ?x')"
using ff' x'ε.arrow by (unfold_locales, auto)
have "G f = x'ε.the_coext (Go ?x) (C f (εo ?x))"
using f G_def by simp
hence Gf: "D.in_hom (G f) (Go ?x) (Go ?x') ∧ f ⋅⇩C εo ?x = εo ?x' ⋅⇩C F (G f)"
using 1 x'ε.the_coext_prop by simp
have "G f' = x''ε.the_coext (Go ?x') (f' ⋅⇩C εo ?x')"
using ff' G_def by auto
hence Gf': "«G f' : Go (C.cod f) →⇩D Go (C.cod f')» ∧ f' ⋅⇩C εo ?x' = εo ?x'' ⋅⇩C F (G f')"
using 2 x''ε.the_coext_prop by simp
show "G (f' ⋅⇩C f) = G f' ⋅⇩D G f"
proof -
have "x''ε.is_coext (Go ?x) ((f' ⋅⇩C f) ⋅⇩C εo ?x) (G f' ⋅⇩D G f)"
proof -
have "«G f' ⋅⇩D G f : Go (C.dom f) →⇩D Go (C.cod f')»" using 1 2 Gf Gf' by auto
moreover have "(f' ⋅⇩C f) ⋅⇩C εo ?x = εo ?x'' ⋅⇩C F (G f' ⋅⇩D G f)"
proof -
have "(f' ⋅⇩C f) ⋅⇩C εo ?x = f' ⋅⇩C f ⋅⇩C εo ?x"
using C.comp_assoc by force
also have "... = (f' ⋅⇩C εo ?x') ⋅⇩C F (G f)"
using Gf C.comp_assoc by fastforce
also have "... = εo ?x'' ⋅⇩C F (G f' ⋅⇩D G f)"
using Gf Gf' C.comp_assoc by fastforce
finally show ?thesis by auto
qed
ultimately show ?thesis using x''ε.is_coext_def by auto
qed
moreover have "arrow_from_functor D C F (Go ?x) ?x'' ((f' ⋅⇩C f) ⋅⇩C εo ?x)"
using ff' xε.arrow by (unfold_locales, blast)
ultimately show ?thesis
using ff' G_def x''ε.the_coext_unique C.seqE C.cod_comp C.dom_comp by auto
qed
qed
interpretation G: "functor" C D G using G_is_functor by auto
lemma G_simp:
assumes "C.arr f"
shows "G f = terminal_arrow_from_functor.the_coext D C F (Go (C.cod f)) (εo (C.cod f))
(Go (C.dom f)) (f ⋅⇩C εo (C.dom f))"
using assms G_def by simp
interpretation idC: identity_functor C ..
interpretation GF: composite_functor C D C G F ..
interpretation ε: transformation_by_components C C GF.map C.map εo
proof
fix x :: 'c
assume x: "C.ide x"
show "«εo x : GF.map x →⇩C C.map x»"
proof -
interpret terminal_arrow_from_functor D C F ‹Go x› x ‹εo x›
using x Go_εo_terminal ex_terminal_arrow by simp
show ?thesis using x G_ide arrow by auto
qed
next
fix f :: 'c
assume f: "C.arr f"
show "εo (C.cod f) ⋅⇩C GF.map f = C.map f ⋅⇩C εo (C.dom f)"
proof -
let ?x = "C.dom f"
let ?x' = "C.cod f"
interpret xε: terminal_arrow_from_functor D C F ‹Go ?x› ?x ‹εo ?x›
using f Go_εo_terminal ex_terminal_arrow by simp
interpret x'ε: terminal_arrow_from_functor D C F ‹Go ?x'› ?x' ‹εo ?x'›
using f Go_εo_terminal ex_terminal_arrow by simp
have 1: "arrow_from_functor D C F (Go ?x) ?x' (C f (εo ?x))"
using f xε.arrow by (unfold_locales, auto)
have "G f = x'ε.the_coext (Go ?x) (f ⋅⇩C εo ?x)"
using f G_simp by blast
hence "x'ε.is_coext (Go ?x) (f ⋅⇩C εo ?x) (G f)"
using 1 x'ε.the_coext_prop x'ε.is_coext_def by auto
thus ?thesis
using f x'ε.is_coext_def by simp
qed
qed
definition ψ
where "ψ x h = C (ε.map x) (F h)"
lemma ψ_in_hom:
assumes "C.ide x" and "«g : y →⇩D G x»"
shows "«ψ x g : F y →⇩C x»"
unfolding ψ_def using assms ε.maps_ide_in_hom by auto
lemma ψ_natural:
assumes f: "«f : x →⇩C x'»" and g: "«g : y' →⇩D y»" and h: "«h : y →⇩D G x»"
shows "f ⋅⇩C ψ x h ⋅⇩C F g = ψ x' ((G f ⋅⇩D h) ⋅⇩D g)"
proof -
have "f ⋅⇩C ψ x h ⋅⇩C F g = f ⋅⇩C (ε.map x ⋅⇩C F h) ⋅⇩C F g"
unfolding ψ_def by auto
also have "... = (f ⋅⇩C ε.map x) ⋅⇩C F h ⋅⇩C F g"
using C.comp_assoc by fastforce
also have "... = (f ⋅⇩C ε.map x) ⋅⇩C F (h ⋅⇩D g)"
using g h by fastforce
also have "... = (ε.map x' ⋅⇩C F (G f)) ⋅⇩C F (h ⋅⇩D g)"
using f ε.naturality by auto
also have "... = ε.map x' ⋅⇩C F ((G f ⋅⇩D h) ⋅⇩D g)"
using f g h C.comp_assoc by fastforce
also have "... = ψ x' ((G f ⋅⇩D h) ⋅⇩D g)"
unfolding ψ_def by auto
finally show ?thesis by auto
qed
lemma ψ_inverts_coext:
assumes x: "C.ide x" and g: "«g : y →⇩D G x»"
shows "arrow_from_functor.is_coext D C F (G x) (ε.map x) y (ψ x g) g"
proof -
interpret xε: arrow_from_functor D C F ‹G x› x ‹ε.map x›
using x ε.maps_ide_in_hom by (unfold_locales, auto)
show "xε.is_coext y (ψ x g) g"
using x g ψ_def xε.is_coext_def G_ide by blast
qed
lemma ψ_invertible:
assumes y: "D.ide y" and f: "«f : F y →⇩C x»"
shows "∃!g. «g : y →⇩D G x» ∧ ψ x g = f"
proof
have x: "C.ide x" using f by auto
interpret xε: terminal_arrow_from_functor D C F ‹Go x› x ‹εo x›
using x ex_terminal_arrow Go_εo_terminal by auto
have 1: "arrow_from_functor D C F y x f"
using y f by (unfold_locales, auto)
let ?g = "xε.the_coext y f"
have "ψ x ?g = f"
using 1 x y ψ_def xε.the_coext_prop G_ide ψ_inverts_coext xε.is_coext_def by simp
thus "«?g : y →⇩D G x» ∧ ψ x ?g = f"
using 1 x xε.the_coext_prop G_ide by simp
show "⋀g'. «g' : y →⇩D G x» ∧ ψ x g' = f ⟹ g' = ?g"
using 1 x y ψ_inverts_coext G_ide xε.the_coext_unique by force
qed
definition φ
where "φ y f = (THE g. «g : y →⇩D G (C.cod f)» ∧ ψ (C.cod f) g = f)"
lemma φ_in_hom:
assumes "D.ide y" and "«f : F y →⇩C x»"
shows "«φ y f : y →⇩D G x»"
using assms ψ_invertible φ_def theI' [of "λg. «g : y →⇩D G x» ∧ ψ x g = f"]
by auto
lemma φ_ψ:
assumes "C.ide x" and "«g : y →⇩D G x»"
shows "φ y (ψ x g) = g"
proof -
have "C.cod (ψ x g) = x"
using assms ψ_in_hom by auto
hence "φ y (ψ x g) = (THE g'. «g' : y →⇩D G x» ∧ ψ x g' = ψ x g)"
using φ_def by auto
moreover have "∃!g'. «g' : y →⇩D G x» ∧ ψ x g' = ψ x g"
using assms ψ_in_hom ψ_invertible D.ide_dom by blast
moreover have "«g : y →⇩D G x» ∧ ψ x g = ψ x g"
using assms(2) by auto
ultimately show "φ y (ψ x g) = g" by auto
qed
lemma ψ_φ:
assumes "D.ide y" and "«f : F y →⇩C x»"
shows "ψ x (φ y f) = f"
using assms ψ_invertible φ_def theI' [of "λg. «g : y →⇩D G x» ∧ ψ x g = f"]
by auto
lemma φ_natural:
assumes "«f : x →⇩C x'»" and "«g : y' →⇩D y»" and "«h : F y →⇩C x»"
shows "φ y' (f ⋅⇩C h ⋅⇩C F g) = (G f ⋅⇩D φ y h) ⋅⇩D g"
proof -
have "C.ide x' ∧ D.ide y ∧ D.in_hom (φ y h) y (G x)"
using assms φ_in_hom by auto
thus ?thesis
using assms D.comp_in_homI G.preserves_hom ψ_natural [of f x x' g y' y "φ y h"] φ_ψ ψ_φ
by auto
qed
theorem induces_meta_adjunction:
shows "meta_adjunction C D F G φ ψ"
using φ_in_hom ψ_in_hom φ_ψ ψ_φ φ_natural D.comp_assoc
by (unfold_locales, simp_all)
end
text‹
A right adjoint functor induces a meta-adjunction, modulo the choice of a
left adjoint and unit.
›
context right_adjoint_functor
begin
definition Fo :: "'d ⇒ 'c"
where "Fo y = (SOME x. ∃u. initial_arrow_to_functor C D G y x u)"
definition ηo :: "'d ⇒ 'd"
where "ηo y = (SOME u. initial_arrow_to_functor C D G y (Fo y) u)"
lemma Fo_ηo_initial:
assumes "∃x u. initial_arrow_to_functor C D G y x u"
shows "initial_arrow_to_functor C D G y (Fo y) (ηo y)"
using assms Fo_def ηo_def
someI_ex [of "λx. ∃u. initial_arrow_to_functor C D G y x u"]
someI_ex [of "λu. initial_arrow_to_functor C D G y (Fo y) u"]
by simp
text‹
The left adjoint @{term F} to @{term g} takes each arrow @{term g} of
@{term[source=true] D} to the unique @{term[source=true] C}-extension of
@{term "D (ηo (D.cod g)) g"} along @{term "ηo (D.dom g)"}.
›
definition F :: "'d ⇒ 'c"
where "F g = (if D.arr g then
initial_arrow_to_functor.the_ext C D G (Fo (D.dom g)) (ηo (D.dom g))
(Fo (D.cod g)) (ηo (D.cod g) ⋅⇩D g)
else C.null)"
lemma F_ide:
assumes "D.ide y"
shows "F y = Fo y"
proof -
interpret initial_arrow_to_functor C D G y ‹Fo y› ‹ηo y›
using assms initial_arrows_exist Fo_ηo_initial by blast
have 1: "arrow_to_functor C D G y (Fo y) (ηo y)" ..
have "is_ext (Fo y) (ηo y) (Fo y)"
unfolding is_ext_def using arrow D.comp_ide_arr [of "G (Fo y)" "ηo y"] by force
hence "Fo y = the_ext (Fo y) (ηo y)" using 1 the_ext_unique by blast
moreover have "ηo y = D (ηo (D.cod y)) y"
using assms arrow D.comp_arr_ide D.comp_arr_dom by auto
ultimately show ?thesis
using assms F_def D.dom_cod D.in_homE D.ide_in_hom by metis
qed
lemma F_is_functor:
shows "functor D C F"
proof
fix g :: 'd
assume "¬D.arr g"
thus "F g = C.null" using F_def by auto
next
fix g :: 'd
assume g: "D.arr g"
let ?y = "D.dom g"
let ?y' = "D.cod g"
interpret yη: initial_arrow_to_functor C D G ?y ‹Fo ?y› ‹ηo ?y›
using g initial_arrows_exist Fo_ηo_initial by simp
interpret y'η: initial_arrow_to_functor C D G ?y' ‹Fo ?y'› ‹ηo ?y'›
using g initial_arrows_exist Fo_ηo_initial by simp
have 1: "arrow_to_functor C D G ?y (Fo ?y') (D (ηo ?y') g)"
using g y'η.arrow by (unfold_locales, auto)
have "F g = yη.the_ext (Fo ?y') (D (ηo ?y') g)"
using g F_def by simp
hence Fg: "«F g : Fo ?y →⇩C Fo ?y'» ∧ ηo ?y' ⋅⇩D g = G (F g) ⋅⇩D ηo ?y"
using 1 yη.the_ext_prop by simp
show "C.arr (F g)" using Fg by auto
show "C.dom (F g) = F ?y" using Fg g F_ide by auto
show "C.cod (F g) = F ?y'" using Fg g F_ide by auto
next
fix g :: 'd
fix g' :: 'd
assume g': "D.arr (D g' g)"
have g: "D.arr g" using g' by auto
let ?y = "D.dom g"
let ?y' = "D.cod g"
let ?y'' = "D.cod g'"
interpret yη: initial_arrow_to_functor C D G ?y ‹Fo ?y› ‹ηo ?y›
using g initial_arrows_exist Fo_ηo_initial by simp
interpret y'η: initial_arrow_to_functor C D G ?y' ‹Fo ?y'› ‹ηo ?y'›
using g initial_arrows_exist Fo_ηo_initial by simp
interpret y''η: initial_arrow_to_functor C D G ?y'' ‹Fo ?y''› ‹ηo ?y''›
using g' initial_arrows_exist Fo_ηo_initial by auto
have 1: "arrow_to_functor C D G ?y (Fo ?y') (ηo ?y' ⋅⇩D g)"
using g y'η.arrow by (unfold_locales, auto)
have "F g = yη.the_ext (Fo ?y') (ηo ?y' ⋅⇩D g)"
using g F_def by simp
hence Fg: "«F g : Fo ?y →⇩C Fo ?y'» ∧ ηo ?y' ⋅⇩D g = G (F g) ⋅⇩D ηo ?y"
using 1 yη.the_ext_prop by simp
have 2: "arrow_to_functor C D G ?y' (Fo ?y'') (ηo ?y'' ⋅⇩D g')"
using g' y''η.arrow by (unfold_locales, auto)
have "F g' = y'η.the_ext (Fo ?y'') (ηo ?y'' ⋅⇩D g')"
using g' F_def by auto
hence Fg': "«F g' : Fo ?y' →⇩C Fo ?y''» ∧ ηo ?y'' ⋅⇩D g' = G (F g') ⋅⇩D ηo ?y'"
using 2 y'η.the_ext_prop by simp
show "F (g' ⋅⇩D g) = F g' ⋅⇩C F g"
proof -
have "yη.is_ext (Fo ?y'') (ηo ?y'' ⋅⇩D g' ⋅⇩D g) (F g' ⋅⇩C F g)"
proof -
have "«F g' ⋅⇩C F g : Fo ?y →⇩C Fo ?y''»" using 1 2 Fg Fg' by auto
moreover have "ηo ?y'' ⋅⇩D g' ⋅⇩D g = G (F g' ⋅⇩C F g) ⋅⇩D ηo ?y"
proof -
have "ηo ?y'' ⋅⇩D g' ⋅⇩D g = (G (F g') ⋅⇩D ηo ?y') ⋅⇩D g"
using Fg' g g' y''η.arrow by (metis D.comp_assoc)
also have "... = G (F g') ⋅⇩D ηo ?y' ⋅⇩D g"
using D.comp_assoc by fastforce
also have "... = G (F g' ⋅⇩C F g) ⋅⇩D ηo ?y"
using Fg Fg' D.comp_assoc by fastforce
finally show ?thesis by auto
qed
ultimately show ?thesis using yη.is_ext_def by auto
qed
moreover have "arrow_to_functor C D G ?y (Fo ?y'') (ηo ?y'' ⋅⇩D g' ⋅⇩D g)"
using g g' y''η.arrow by (unfold_locales, auto)
ultimately show ?thesis
using g g' F_def yη.the_ext_unique D.dom_comp D.cod_comp by auto
qed
qed
interpretation F: "functor" D C F using F_is_functor by auto
lemma F_simp:
assumes "D.arr g"
shows "F g = initial_arrow_to_functor.the_ext C D G (Fo (D.dom g)) (ηo (D.dom g))
(Fo (D.cod g)) (ηo (D.cod g) ⋅⇩D g)"
using assms F_def by simp
interpretation FG: composite_functor D C D F G ..
interpretation η: transformation_by_components D D D.map FG.map ηo
proof
fix y :: 'd
assume y: "D.ide y"
show "«ηo y : D.map y →⇩D FG.map y»"
proof -
interpret initial_arrow_to_functor C D G y ‹Fo y› ‹ηo y›
using y Fo_ηo_initial initial_arrows_exist by simp
show ?thesis using y F_ide arrow by auto
qed
next
fix g :: 'd
assume g: "D.arr g"
show "ηo (D.cod g) ⋅⇩D D.map g = FG.map g ⋅⇩D ηo (D.dom g)"
proof -
let ?y = "D.dom g"
let ?y' = "D.cod g"
interpret yη: initial_arrow_to_functor C D G ?y ‹Fo ?y› ‹ηo ?y›
using g Fo_ηo_initial initial_arrows_exist by simp
interpret y'η: initial_arrow_to_functor C D G ?y' ‹Fo ?y'› ‹ηo ?y'›
using g Fo_ηo_initial initial_arrows_exist by simp
have "arrow_to_functor C D G ?y (Fo ?y') (ηo ?y' ⋅⇩D g)"
using g y'η.arrow by (unfold_locales, auto)
moreover have "F g = yη.the_ext (Fo ?y') (ηo ?y' ⋅⇩D g)"
using g F_simp by blast
ultimately have "yη.is_ext (Fo ?y') (ηo ?y' ⋅⇩D g) (F g)"
using yη.the_ext_prop yη.is_ext_def by auto
thus ?thesis
using g yη.is_ext_def by simp
qed
qed
definition φ
where "φ y h = D (G h) (η.map y)"
lemma φ_in_hom:
assumes y: "D.ide y" and f: "«f : F y →⇩C x»"
shows "«φ y f : y →⇩D G x»"
unfolding φ_def using assms η.maps_ide_in_hom by auto
lemma φ_natural:
assumes f: "«f : x →⇩C x'»" and g: "«g : y' →⇩D y»" and h: "«h : F y →⇩C x»"
shows "φ y' (f ⋅⇩C h ⋅⇩C F g) = (G f ⋅⇩D φ y h) ⋅⇩D g"
proof -
have "(G f ⋅⇩D φ y h) ⋅⇩D g = (G f ⋅⇩D G h ⋅⇩D η.map y) ⋅⇩D g"
unfolding φ_def by auto
also have "... = (G f ⋅⇩D G h) ⋅⇩D η.map y ⋅⇩D g"
using D.comp_assoc by fastforce
also have "... = G (f ⋅⇩C h) ⋅⇩D G (F g) ⋅⇩D η.map y'"
using f g h η.naturality by fastforce
also have "... = (G (f ⋅⇩C h) ⋅⇩D G (F g)) ⋅⇩D η.map y'"
using D.comp_assoc by fastforce
also have "... = G (f ⋅⇩C h ⋅⇩C F g) ⋅⇩D η.map y'"
using f g h D.comp_assoc by fastforce
also have "... = φ y' (f ⋅⇩C h ⋅⇩C F g)"
unfolding φ_def by auto
finally show ?thesis by auto
qed
lemma φ_inverts_ext:
assumes y: "D.ide y" and f: "«f : F y →⇩C x»"
shows "arrow_to_functor.is_ext C D G (F y) (η.map y) x (φ y f) f"
proof -
interpret yη: arrow_to_functor C D G y ‹F y› ‹η.map y›
using y η.maps_ide_in_hom by (unfold_locales, auto)
show "yη.is_ext x (φ y f) f"
using f y φ_def yη.is_ext_def F_ide by (unfold_locales, auto)
qed
lemma φ_invertible:
assumes x: "C.ide x" and g: "«g : y →⇩D G x»"
shows "∃!f. «f : F y →⇩C x» ∧ φ y f = g"
proof
have y: "D.ide y" using g by auto
interpret yη: initial_arrow_to_functor C D G y ‹Fo y› ‹ηo y›
using y initial_arrows_exist Fo_ηo_initial by auto
have 1: "arrow_to_functor C D G y x g"
using x g by (unfold_locales, auto)
let ?f = "yη.the_ext x g"
have "φ y ?f = g"
using φ_def yη.the_ext_prop 1 F_ide x y φ_inverts_ext yη.is_ext_def by fastforce
moreover have "«?f : F y →⇩C x»"
using 1 y yη.the_ext_prop F_ide by simp
ultimately show "«?f : F y →⇩C x» ∧ φ y ?f = g" by auto
show "⋀f'. «f' : F y →⇩C x» ∧ φ y f' = g ⟹ f' = ?f"
using 1 y φ_inverts_ext yη.the_ext_unique F_ide by force
qed
definition ψ
where "ψ x g = (THE f. «f : F (D.dom g) →⇩C x» ∧ φ (D.dom g) f = g)"
lemma ψ_in_hom:
assumes "C.ide x" and "«g : y →⇩D G x»"
shows "C.in_hom (ψ x g) (F y) x"
using assms φ_invertible ψ_def theI' [of "λf. «f : F y →⇩C x» ∧ φ y f = g"]
by auto
lemma ψ_φ:
assumes "D.ide y" and "«f : F y →⇩C x»"
shows "ψ x (φ y f) = f"
proof -
have "D.dom (φ y f) = y" using assms φ_in_hom by blast
hence "ψ x (φ y f) = (THE f'. «f' : F y →⇩C x» ∧ φ y f' = φ y f)"
using ψ_def by auto
moreover have "∃!f'. «f' : F y →⇩C x» ∧ φ y f' = φ y f"
using assms φ_in_hom φ_invertible C.ide_cod by blast
ultimately show ?thesis using assms(2) by auto
qed
lemma φ_ψ:
assumes "C.ide x" and "«g : y →⇩D G x»"
shows "φ y (ψ x g) = g"
using assms φ_invertible ψ_def theI' [of "λf. «f : F y →⇩C x» ∧ φ y f = g"]
by auto
theorem induces_meta_adjunction:
shows "meta_adjunction C D F G φ ψ"
using φ_in_hom ψ_in_hom φ_ψ ψ_φ φ_natural D.comp_assoc
by (unfold_locales, auto)
end
section "Meta-Adjunctions Induce Hom-Adjunctions"
text‹
To obtain a hom-adjunction from a meta-adjunction, we need to exhibit hom-functors
from @{term C} and @{term D} to a common set category @{term S}, so it is necessary
to apply an actual concrete construction of such a category.
We use the replete set category generated by the disjoint sum
@{typ "('c+'d)"} of the arrow types of @{term C} and @{term D}.
›
context meta_adjunction
begin
interpretation S: replete_setcat ‹undefined :: 'c+'d› .
definition inC :: "'c ⇒ ('c+'d) setcat.arr"
where "inC ≡ S.UP o Inl"
definition inD :: "'d ⇒ ('c+'d) setcat.arr"
where "inD ≡ S.UP o Inr"
interpretation Cop: dual_category C ..
interpretation Dop: dual_category D ..
interpretation CopxC: product_category Cop.comp C ..
interpretation DopxD: product_category Dop.comp D ..
interpretation DopxC: product_category Dop.comp C ..
interpretation HomC: hom_functor C S.comp ‹λ_. inC›
proof
show "⋀f. C.arr f ⟹ inC f ∈ S.Univ"
unfolding inC_def using S.UP_mapsto by auto
show "⋀b a. ⟦C.ide b; C.ide a⟧ ⟹ inj_on inC (C.hom b a)"
unfolding inC_def
using S.inj_UP
by (metis injD inj_Inl inj_compose inj_on_def)
qed
interpretation HomD: hom_functor D S.comp ‹λ_. inD›
proof
show "⋀f. D.arr f ⟹ inD f ∈ S.Univ"
unfolding inD_def using S.UP_mapsto by auto
show "⋀b a. ⟦D.ide b; D.ide a⟧ ⟹ inj_on inD (D.hom b a)"
unfolding inD_def
using S.inj_UP
by (metis injD inj_Inr inj_compose inj_on_def)
qed
interpretation Fop: dual_functor D C F ..
interpretation FopxC: product_functor Dop.comp C Cop.comp C Fop.map C.map ..
interpretation DopxG: product_functor Dop.comp C Dop.comp D Dop.map G ..
interpretation Hom_FopxC: composite_functor DopxC.comp CopxC.comp S.comp
FopxC.map HomC.map ..
interpretation Hom_DopxG: composite_functor DopxC.comp DopxD.comp S.comp
DopxG.map HomD.map ..
lemma inC_ψ [simp]:
assumes "C.ide b" and "C.ide a" and "x ∈ inC ` C.hom b a"
shows "inC (HomC.ψ (b, a) x) = x"
using assms by auto
lemma ψ_inC [simp]:
assumes "C.arr f"
shows "HomC.ψ (C.dom f, C.cod f) (inC f) = f"
using assms HomC.ψ_φ by blast
lemma inD_ψ [simp]:
assumes "D.ide b" and "D.ide a" and "x ∈ inD ` D.hom b a"
shows "inD (HomD.ψ (b, a) x) = x"
using assms by auto
lemma ψ_inD [simp]:
assumes "D.arr f"
shows "HomD.ψ (D.dom f, D.cod f) (inD f) = f"
using assms HomD.ψ_φ by blast
lemma Hom_FopxC_simp:
assumes "DopxC.arr gf"
shows "Hom_FopxC.map gf =
S.mkArr (HomC.set (F (D.cod (fst gf)), C.dom (snd gf)))
(HomC.set (F (D.dom (fst gf)), C.cod (snd gf)))
(inC ∘ (λh. snd gf ⋅⇩C h ⋅⇩C F (fst gf))
∘ HomC.ψ (F (D.cod (fst gf)), C.dom (snd gf)))"
using assms HomC.map_def by simp
lemma Hom_DopxG_simp:
assumes "DopxC.arr gf"
shows "Hom_DopxG.map gf =
S.mkArr (HomD.set (D.cod (fst gf), G (C.dom (snd gf))))
(HomD.set (D.dom (fst gf), G (C.cod (snd gf))))
(inD ∘ (λh. G (snd gf) ⋅⇩D h ⋅⇩D fst gf)
∘ HomD.ψ (D.cod (fst gf), G (C.dom (snd gf))))"
using assms HomD.map_def by simp
definition Φo
where "Φo yx = S.mkArr (HomC.set (F (fst yx), snd yx))
(HomD.set (fst yx, G (snd yx)))
(inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))"
lemma Φo_in_hom:
assumes yx: "DopxC.ide yx"
shows "«Φo yx : Hom_FopxC.map yx →⇩S Hom_DopxG.map yx»"
proof -
have "Hom_FopxC.map yx = S.mkIde (HomC.set (F (fst yx), snd yx))"
using yx HomC.map_ide by auto
moreover have "Hom_DopxG.map yx = S.mkIde (HomD.set (fst yx, G (snd yx)))"
using yx HomD.map_ide by auto
moreover have
"«S.mkArr (HomC.set (F (fst yx), snd yx)) (HomD.set (fst yx, G (snd yx)))
(inD ∘ φ (fst yx) ∘ HomC.ψ (F (fst yx), snd yx)) :
S.mkIde (HomC.set (F (fst yx), snd yx))
→⇩S S.mkIde (HomD.set (fst yx, G (snd yx)))»"
proof (intro S.mkArr_in_hom)
show "HomC.set (F (fst yx), snd yx) ⊆ S.Univ" using yx HomC.set_subset_Univ by simp
show "HomD.set (fst yx, G (snd yx)) ⊆ S.Univ" using yx HomD.set_subset_Univ by simp
show "inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx)
∈ HomC.set (F (fst yx), snd yx) → HomD.set (fst yx, G (snd yx))"
proof
fix x
assume x: "x ∈ HomC.set (F (fst yx), snd yx)"
show "(inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx)) x
∈ HomD.set (fst yx, G (snd yx))"
using x yx HomC.ψ_mapsto [of "F (fst yx)" "snd yx"]
φ_in_hom [of "fst yx"] HomD.φ_mapsto [of "fst yx" "G (snd yx)"]
by auto
qed
qed
ultimately show ?thesis using Φo_def by auto
qed
interpretation Φ: transformation_by_components DopxC.comp S.comp
Hom_FopxC.map Hom_DopxG.map Φo
proof
fix yx
assume yx: "DopxC.ide yx"
show "«Φo yx : Hom_FopxC.map yx →⇩S Hom_DopxG.map yx»"
using yx Φo_in_hom by auto
next
fix gf
assume gf: "DopxC.arr gf"
show "S.comp (Φo (DopxC.cod gf)) (Hom_FopxC.map gf)
= S.comp (Hom_DopxG.map gf) (Φo (DopxC.dom gf))"
proof -
let ?g = "fst gf"
let ?f = "snd gf"
let ?x = "C.dom ?f"
let ?x' = "C.cod ?f"
let ?y = "D.cod ?g"
let ?y' = "D.dom ?g"
let ?Fy = "F ?y"
let ?Fy' = "F ?y'"
let ?Fg = "F ?g"
let ?Gx = "G ?x"
let ?Gx' = "G ?x'"
let ?Gf = "G ?f"
have 1: "S.arr (Hom_FopxC.map gf) ∧
Hom_FopxC.map gf = S.mkArr (HomC.set (?Fy, ?x)) (HomC.set (?Fy', ?x'))
(inC o (λh. ?f ⋅⇩C h ⋅⇩C ?Fg) o HomC.ψ (?Fy, ?x))"
using gf Hom_FopxC.preserves_arr Hom_FopxC_simp by blast
have 2: "S.arr (Φo (DopxC.cod gf)) ∧
Φo (DopxC.cod gf) = S.mkArr (HomC.set (?Fy', ?x')) (HomD.set (?y', ?Gx'))
(inD o φ ?y' o HomC.ψ (?Fy', ?x'))"
using gf Φo_in_hom [of "DopxC.cod gf"] Φo_def [of "DopxC.cod gf"] φ_in_hom
S.card_of_leq
by auto
have 3: "S.arr (Φo (DopxC.dom gf)) ∧
Φo (DopxC.dom gf) = S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y, ?Gx))
(inD o φ ?y o HomC.ψ (?Fy, ?x))"
using gf Φo_in_hom [of "DopxC.dom gf"] Φo_def [of "DopxC.dom gf"] φ_in_hom
S.card_of_leq
by auto
have 4: "S.arr (Hom_DopxG.map gf) ∧
Hom_DopxG.map gf = S.mkArr (HomD.set (?y, ?Gx)) (HomD.set (?y', ?Gx'))
(inD o (λh. ?Gf ⋅⇩D h ⋅⇩D ?g) o HomD.ψ (?y, ?Gx))"
using gf Hom_DopxG.preserves_arr Hom_DopxG_simp by blast
have 5: "S.seq (Φo (DopxC.cod gf)) (Hom_FopxC.map gf) ∧
S.comp (Φo (DopxC.cod gf)) (Hom_FopxC.map gf)
= S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
o (inC o (λh. ?f ⋅⇩C h ⋅⇩C ?Fg) o HomC.ψ (?Fy, ?x)))"
proof -
have "S.seq (Φo (DopxC.cod gf)) (Hom_FopxC.map gf)"
using gf 1 2 Φo_in_hom Hom_FopxC.preserves_hom
by (intro S.seqI', auto)
thus ?thesis
using S.comp_mkArr 1 2 by metis
qed
have 6: "S.comp (Hom_DopxG.map gf) (Φo (DopxC.dom gf))
= S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
((inD o (λh. ?Gf ⋅⇩D h ⋅⇩D ?g) o HomD.ψ (?y, ?Gx))
o (inD o φ ?y o HomC.ψ (?Fy, ?x)))"
proof -
have "S.seq (Hom_DopxG.map gf) (Φo (DopxC.dom gf))"
using gf 3 4 S.arr_mkArr S.cod_mkArr S.dom_mkArr
by (intro S.seqI', auto)
thus ?thesis
using 3 4 S.comp_mkArr by metis
qed
have 7:
"restrict ((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
o (inC o (λh. ?f ⋅⇩C h ⋅⇩C ?Fg) o HomC.ψ (?Fy, ?x))) (HomC.set (?Fy, ?x))
= restrict ((inD o (λh. ?Gf ⋅⇩D h ⋅⇩D ?g) o HomD.ψ (?y, ?Gx))
o (inD o φ ?y o HomC.ψ (?Fy, ?x))) (HomC.set (?Fy, ?x))"
proof (intro restrict_ext)
show "⋀h. h ∈ HomC.set (?Fy, ?x) ⟹
((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
o (inC o (λh. ?f ⋅⇩C h ⋅⇩C ?Fg) o HomC.ψ (?Fy, ?x))) h
= ((inD o (λh. ?Gf ⋅⇩D h ⋅⇩D ?g) o HomD.ψ (?y, ?Gx))
o (inD o φ ?y o HomC.ψ (?Fy, ?x))) h"
proof -
fix h
assume h: "h ∈ HomC.set (?Fy, ?x)"
have ψh: "«HomC.ψ (?Fy, ?x) h : ?Fy →⇩C ?x»"
using gf h HomC.ψ_mapsto [of ?Fy ?x] CopxC.ide_char by auto
show "((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
o (inC o (λh. ?f ⋅⇩C h ⋅⇩C ?Fg) o HomC.ψ (?Fy, ?x))) h
= ((inD o (λh. ?Gf ⋅⇩D h ⋅⇩D ?g) o HomD.ψ (?y, ?Gx))
o (inD o φ ?y o HomC.ψ (?Fy, ?x))) h"
proof -
have
"((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
o (inC o (λh. ?f ⋅⇩C h ⋅⇩C ?Fg) o HomC.ψ (?Fy, ?x))) h
= inD (φ ?y' (HomC.ψ (?Fy', ?x') (inC (?f ⋅⇩C HomC.ψ (?Fy, ?x) h ⋅⇩C ?Fg))))"
by simp
also have "... = inD (φ ?y' (?f ⋅⇩C HomC.ψ (?Fy, ?x) h ⋅⇩C ?Fg))"
using gf ψh HomC.φ_mapsto HomC.ψ_mapsto φ_in_hom
ψ_inC [of "?f ⋅⇩C HomC.ψ (?Fy, ?x) h ⋅⇩C ?Fg"]
by auto
also have "... = inD (D ?Gf (D (φ ?y (HomC.ψ (?Fy, ?x) h)) ?g))"
proof -
have "«?f : C.dom ?f → C.cod ?f»"
using gf by auto
moreover have "«?g : D.dom ?g →⇩D D.cod ?g»"
using gf by auto
ultimately show ?thesis
using gf ψh φ_in_hom G.preserves_hom C.in_homE D.in_homE
φ_naturality [of ?f ?x ?x' ?g ?y' ?y "HomC.ψ (?Fy, ?x) h"]
by simp
qed
also have "... =
inD (D ?Gf (D (HomD.ψ (?y, ?Gx) (inD (φ ?y (HomC.ψ (?Fy, ?x) h)))) ?g))"
using gf ψh φ_in_hom by simp
also have "... = ((inD o (λh. ?Gf ⋅⇩D h ⋅⇩D ?g) o HomD.ψ (?y, ?Gx))
o (inD o φ ?y o HomC.ψ (?Fy, ?x))) h"
by simp
finally show ?thesis by auto
qed
qed
qed
have 8: "S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
o (inC o (λh. ?f ⋅⇩C h ⋅⇩C ?Fg) o HomC.ψ (?Fy, ?x)))
= S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
((inD o (λh. ?Gf ⋅⇩D h ⋅⇩D ?g) o HomD.ψ (?y, ?Gx))
o (inD o φ ?y o HomC.ψ (?Fy, ?x)))"
proof (intro S.mkArr_eqI')
show "S.arr (S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
o (inC o (λh. ?f ⋅⇩C h ⋅⇩C ?Fg) o HomC.ψ (?Fy, ?x))))"
using 5 by metis
show "⋀t. t ∈ HomC.set (?Fy, ?x) ⟹
((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
o (inC o (λh. ?f ⋅⇩C h ⋅⇩C ?Fg) o HomC.ψ (?Fy, ?x))) t
= ((inD o (λh. ?Gf ⋅⇩D h ⋅⇩D ?g) o HomD.ψ (?y, ?Gx))
o (inD o φ ?y o HomC.ψ (?Fy, ?x))) t"
using 7 restrict_apply by fast
qed
show ?thesis using 5 6 8 by auto
qed
qed
lemma Φ_simp:
assumes YX: "DopxC.ide yx"
shows "Φ.map yx =
S.mkArr (HomC.set (F (fst yx), snd yx)) (HomD.set (fst yx, G (snd yx)))
(inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))"
using YX Φo_def by simp
abbreviation Ψo
where "Ψo yx ≡ S.mkArr (HomD.set (fst yx, G (snd yx))) (HomC.set (F (fst yx), snd yx))
(inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))"
lemma Ψo_in_hom:
assumes yx: "DopxC.ide yx"
shows "«Ψo yx : Hom_DopxG.map yx →⇩S Hom_FopxC.map yx»"
proof -
have "Hom_FopxC.map yx = S.mkIde (HomC.set (F (fst yx), snd yx))"
using yx HomC.map_ide by auto
moreover have "Hom_DopxG.map yx = S.mkIde (HomD.set (fst yx, G (snd yx)))"
using yx HomD.map_ide by auto
moreover have "«Ψo yx : S.mkIde (HomD.set (fst yx, G (snd yx)))
→⇩S S.mkIde (HomC.set (F (fst yx), snd yx))»"
proof (intro S.mkArr_in_hom)
show "HomC.set (F (fst yx), snd yx) ⊆ S.Univ" using yx HomC.set_subset_Univ by simp
show "HomD.set (fst yx, G (snd yx)) ⊆ S.Univ" using yx HomD.set_subset_Univ by simp
show "inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx))
∈ HomD.set (fst yx, G (snd yx)) → HomC.set (F (fst yx), snd yx)"
proof
fix x
assume x: "x ∈ HomD.set (fst yx, G (snd yx))"
show "(inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx))) x
∈ HomC.set (F (fst yx), snd yx)"
using x yx HomD.ψ_mapsto [of "fst yx" "G (snd yx)"] ψ_in_hom [of "snd yx"]
HomC.φ_mapsto [of "F (fst yx)" "snd yx"]
by auto
qed
qed
ultimately show ?thesis by auto
qed
lemma Φ_inv:
assumes yx: "DopxC.ide yx"
shows "S.inverse_arrows (Φ.map yx) (Ψo yx)"
proof -
have 1: "«Φ.map yx : Hom_FopxC.map yx →⇩S Hom_DopxG.map yx»"
using yx Φ.preserves_hom [of yx yx yx] DopxC.ide_in_hom by blast
have 2: "«Ψo yx : Hom_DopxG.map yx →⇩S Hom_FopxC.map yx»"
using yx Ψo_in_hom by simp
have 3: "Φ.map yx = S.mkArr (HomC.set (F (fst yx), snd yx))
(HomD.set (fst yx, G (snd yx)))
(inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))"
using yx Φ_simp by blast
have antipar: "S.antipar (Φ.map yx) (Ψo yx)"
using 1 2 by blast
moreover have "S.ide (S.comp (Ψo yx) (Φ.map yx))"
proof -
have "S.comp (Ψo yx) (Φ.map yx) =
S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx))
((inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))
o (inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx)))"
using 1 2 3 antipar S.comp_mkArr by auto
also have
"... = S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx))
(λx. x)"
proof -
have
"S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx)) (λx. x)
= ..."
proof
show
"S.arr (S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx))
(λx. x))"
using yx HomC.set_subset_Univ S.arr_mkArr by simp
show "⋀x. x ∈ HomC.set (F (fst yx), snd yx) ⟹
x = ((inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))
o (inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))) x"
proof -
fix x
assume x: "x ∈ HomC.set (F (fst yx), snd yx)"
have "((inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))
o (inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))) x
= inC (ψ (snd yx) (HomD.ψ (fst yx, G (snd yx))
(inD (φ (fst yx) (HomC.ψ (F (fst yx), snd yx) x)))))"
by simp
also have "... = inC (ψ (snd yx) (φ (fst yx) (HomC.ψ (F (fst yx), snd yx) x)))"
using x yx HomC.ψ_mapsto [of "F (fst yx)" "snd yx"] φ_in_hom by force
also have "... = inC (HomC.ψ (F (fst yx), snd yx) x)"
using x yx HomC.ψ_mapsto [of "F (fst yx)" "snd yx"] ψ_φ by force
also have "... = x" using x yx inC_ψ by simp
finally show "x = ((inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))
o (inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))) x"
by auto
qed
qed
thus ?thesis by auto
qed
also have "... = S.mkIde (HomC.set (F (fst yx), snd yx))"
using yx S.mkIde_as_mkArr HomC.set_subset_Univ by force
finally have
"S.comp (Ψo yx) (Φ.map yx) = S.mkIde (HomC.set (F (fst yx), snd yx))"
by auto
thus ?thesis using yx HomC.set_subset_Univ S.ide_mkIde by simp
qed
moreover have "S.ide (S.comp (Φ.map yx) (Ψo yx))"
proof -
have "S.comp (Φ.map yx) (Ψo yx) =
S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx)))
((inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))
o (inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx))))"
using 1 2 3 S.comp_mkArr antipar by fastforce
also
have "... = S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx)))
(λx. x)"
proof -
have
"S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx))) (λx. x)
= ..."
proof
show
"S.arr (S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx)))
(λx. x))"
using yx HomD.set_subset_Univ S.arr_mkArr by simp
show "⋀x. x ∈ (HomD.set (fst yx, G (snd yx))) ⟹
x = ((inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))
o (inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))) x"
proof -
fix x
assume x: "x ∈ HomD.set (fst yx, G (snd yx))"
have "((inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))
o (inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))) x
= inD (φ (fst yx) (HomC.ψ (F (fst yx), snd yx)
(inC (ψ (snd yx) (HomD.ψ (fst yx, G (snd yx)) x)))))"
by simp
also have "... = inD (φ (fst yx) (ψ (snd yx) (HomD.ψ (fst yx, G (snd yx)) x)))"
proof -
have "«ψ (snd yx) (HomD.ψ (fst yx, G (snd yx)) x) : F (fst yx) → snd yx»"
using x yx HomD.ψ_mapsto [of "fst yx" "G (snd yx)"] ψ_in_hom by auto
thus ?thesis by simp
qed
also have "... = inD (HomD.ψ (fst yx, G (snd yx)) x)"
using x yx HomD.ψ_mapsto [of "fst yx" "G (snd yx)"] φ_ψ by force
also have "... = x" using x yx inD_ψ by simp
finally show "x = ((inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))
o (inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))) x"
by auto
qed
qed
thus ?thesis by auto
qed
also have "... = S.mkIde (HomD.set (fst yx, G (snd yx)))"
using yx S.mkIde_as_mkArr HomD.set_subset_Univ by force
finally have
"S.comp (Φ.map yx) (Ψo yx) = S.mkIde (HomD.set (fst yx, G (snd yx)))"
by auto
thus ?thesis using yx HomD.set_subset_Univ S.ide_mkIde by simp
qed
ultimately show ?thesis by auto
qed
interpretation Φ: natural_isomorphism DopxC.comp S.comp
Hom_FopxC.map Hom_DopxG.map Φ.map
apply (unfold_locales) using Φ_inv by blast
interpretation Ψ: inverse_transformation DopxC.comp S.comp
Hom_FopxC.map Hom_DopxG.map Φ.map ..
interpretation ΦΨ: inverse_transformations DopxC.comp S.comp
Hom_FopxC.map Hom_DopxG.map Φ.map Ψ.map
using Ψ.inverts_components by (unfold_locales, simp)
abbreviation Φ where "Φ ≡ Φ.map"
abbreviation Ψ where "Ψ ≡ Ψ.map"
abbreviation HomC where "HomC ≡ HomC.map"
abbreviation φC where "φC ≡ λ_. inC"
abbreviation HomD where "HomD ≡ HomD.map"
abbreviation φD where "φD ≡ λ_. inD"
theorem induces_hom_adjunction: "hom_adjunction C D S.comp φC φD F G Φ Ψ"
using F.is_extensional by (unfold_locales, auto)
lemma Ψ_simp:
assumes yx: "DopxC.ide yx"
shows "Ψ yx = S.mkArr (HomD.set (fst yx, G (snd yx))) (HomC.set (F (fst yx), snd yx))
(inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))"
using assms Φo_def Φ_inv S.inverse_unique by simp
text‹
The original @{term φ} and @{term ψ} can be recovered from @{term Φ} and @{term Ψ}.
›
interpretation Φ: set_valued_transformation DopxC.comp S.comp
Hom_FopxC.map Hom_DopxG.map Φ.map ..
interpretation Ψ: set_valued_transformation DopxC.comp S.comp
Hom_DopxG.map Hom_FopxC.map Ψ.map ..
lemma φ_in_terms_of_Φ':
assumes y: "D.ide y" and f: "«f: F y →⇩C x»"
shows "φ y f = (HomD.ψ (y, G x) o Φ.FUN (y, x) o inC) f"
proof -
have x: "C.ide x" using f by auto
have 1: "S.arr (Φ (y, x))" using x y by fastforce
have 2: "Φ (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(inD o φ y o HomC.ψ (F y, x))"
using x y Φo_def by auto
have "(HomD.ψ (y, G x) o Φ.FUN (y, x) o inC) f =
HomD.ψ (y, G x)
(restrict (inD o φ y o HomC.ψ (F y, x)) (HomC.set (F y, x)) (inC f))"
using 1 2 by simp
also have "... = φ y f"
using x y f HomC.φ_mapsto φ_in_hom HomC.ψ_mapsto C.ide_in_hom D.ide_in_hom
by auto
finally show ?thesis by auto
qed
lemma ψ_in_terms_of_Ψ':
assumes x: "C.ide x" and g: "«g : y →⇩D G x»"
shows "ψ x g = (HomC.ψ (F y, x) o Ψ.FUN (y, x) o inD) g"
proof -
have y: "D.ide y" using g by auto
have 1: "S.arr (Ψ (y, x))"
using x y Ψ.preserves_reflects_arr [of "(y, x)"] by simp
have 2: "Ψ (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(inC o ψ x o HomD.ψ (y, G x))"
using x y Ψ_simp by force
have "(HomC.ψ (F y, x) o Ψ.FUN (y, x) o inD) g =
HomC.ψ (F y, x)
(restrict (inC o ψ x o HomD.ψ (y, G x)) (HomD.set (y, G x)) (inD g))"
using 1 2 by simp
also have "... = ψ x g"
using x y g HomD.φ_mapsto ψ_in_hom HomD.ψ_mapsto C.ide_in_hom D.ide_in_hom
by auto
finally show ?thesis by auto
qed
end
section "Hom-Adjunctions Induce Meta-Adjunctions"
context hom_adjunction
begin
definition φ :: "'d ⇒ 'c ⇒ 'd"
where
"φ y h = (HomD.ψ (y, G (C.cod h)) o Φ.FUN (y, C.cod h) o φC (F y, C.cod h)) h"
definition ψ :: "'c ⇒ 'd ⇒ 'c"
where
"ψ x h = (HomC.ψ (F (D.dom h), x) o Ψ.FUN (D.dom h, x) o φD (D.dom h, G x)) h"
lemma Hom_FopxC_map_simp:
assumes "DopxC.arr gf"
shows "Hom_FopxC.map gf =
S.mkArr (HomC.set (F (D.cod (fst gf)), C.dom (snd gf)))
(HomC.set (F (D.dom (fst gf)), C.cod (snd gf)))
(φC (F (D.dom (fst gf)), C.cod (snd gf))
o (λh. snd gf ⋅⇩C h ⋅⇩C F (fst gf))
o HomC.ψ (F (D.cod (fst gf)), C.dom (snd gf)))"
using assms HomC.map_def by simp
lemma Hom_DopxG_map_simp:
assumes "DopxC.arr gf"
shows "Hom_DopxG.map gf =
S.mkArr (HomD.set (D.cod (fst gf), G (C.dom (snd gf))))
(HomD.set (D.dom (fst gf), G (C.cod (snd gf))))
(φD (D.dom (fst gf), G (C.cod (snd gf)))
o (λh. G (snd gf) ⋅⇩D h ⋅⇩D fst gf)
o HomD.ψ (D.cod (fst gf), G (C.dom (snd gf))))"
using assms HomD.map_def by simp
lemma Φ_Fun_mapsto:
assumes "D.ide y" and "«f : F y →⇩C x»"
shows "Φ.FUN (y, x) ∈ HomC.set (F y, x) → HomD.set (y, G x)"
proof -
have "S.arr (Φ (y, x)) ∧ Φ.DOM (y, x) = HomC.set (F y, x) ∧
Φ.COD (y, x) = HomD.set (y, G x)"
using assms HomC.set_map HomD.set_map by auto
thus ?thesis using S.Fun_mapsto by blast
qed
lemma φ_mapsto:
assumes y: "D.ide y"
shows "φ y ∈ C.hom (F y) x → D.hom y (G x)"
proof
fix h
assume h: "h ∈ C.hom (F y) x"
hence 1: " «h : F y →⇩C x»" by simp
show "φ y h ∈ D.hom y (G x)"
proof -
have "φC (F y, x) h ∈ HomC.set (F y, x)"
using y h 1 HomC.φ_mapsto [of "F y" x] by fastforce
hence "Φ.FUN (y, x) (φC (F y, x) h) ∈ HomD.set (y, G x)"
using h y Φ_Fun_mapsto by auto
thus ?thesis
using y h 1 φ_def HomC.φ_mapsto HomD.ψ_mapsto [of y "G x"] by fastforce
qed
qed
lemma Φ_simp:
assumes "D.ide y" and "C.ide x"
shows "S.arr (Φ (y, x))"
and "Φ (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(φD (y, G x) o φ y o ψC (F y, x))"
proof -
show 1: "S.arr (Φ (y, x))" using assms by auto
hence "Φ (y, x) = S.mkArr (Φ.DOM (y, x)) (Φ.COD (y, x)) (Φ.FUN (y, x))"
using S.mkArr_Fun by metis
also have "... = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x)) (Φ.FUN (y, x))"
using assms HomC.set_map HomD.set_map by fastforce
also have "... = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(φD (y, G x) o φ y o ψC (F y, x))"
proof (intro S.mkArr_eqI')
show 2: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x)) (Φ.FUN (y, x)))"
using 1 calculation by argo
show "⋀h. h ∈ HomC.set (F y, x) ⟹
Φ.FUN (y, x) h = (φD (y, G x) o φ y o ψC (F y, x)) h"
proof -
fix h
assume h: "h ∈ HomC.set (F y, x)"
hence "«ψC (F y, x) h : F y →⇩C x»"
using assms HomC.ψ_mapsto [of "F y" x] by auto
hence "(φD (y, G x) o φ y o HomC.ψ (F y, x)) h =
φD (y, G x) (ψD (y, G x) (Φ.FUN (y, x) (φC (F y, x) (ψC (F y, x) h))))"
using h φ_def by auto
also have "... = φD (y, G x) (ψD (y, G x) (Φ.FUN (y, x) h))"
using assms h HomC.φ_ψ Φ_Fun_mapsto by simp
also have "... = Φ.FUN (y, x) h"
using assms h Φ_Fun_mapsto [of y "ψC (F y, x) h"] HomC.ψ_mapsto
HomD.φ_ψ [of y "G x"] C.ide_in_hom D.ide_in_hom
by (meson 2 G.preserves_ide S.arr_mkArr funcset_mem)
finally show "Φ.FUN (y, x) h = (φD (y, G x) o φ y o ψC (F y, x)) h" by auto
qed
qed
finally show "Φ (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(φD (y, G x) o φ y o ψC (F y, x))"
by force
qed
lemma Ψ_Fun_mapsto:
assumes "C.ide x" and "«g : y →⇩D G x»"
shows "Ψ.FUN (y, x) ∈ HomD.set (y, G x) → HomC.set (F y, x)"
proof -
have "S.arr (Ψ (y, x)) ∧ Ψ.COD (y, x) = HomC.set (F y, x) ∧
Ψ.DOM (y, x) = HomD.set (y, G x)"
using assms HomC.set_map HomD.set_map by auto
thus ?thesis using S.Fun_mapsto by fast
qed
lemma ψ_mapsto:
assumes x: "C.ide x"
shows "ψ x ∈ D.hom y (G x) → C.hom (F y) x"
proof
fix h
assume h: "h ∈ D.hom y (G x)"
hence 1: "«h : y →⇩D G x»" by auto
show "ψ x h ∈ C.hom (F y) x"
proof -
have "φD (y, G x) h ∈ HomD.set (y, G x)"
using x h 1 HomD.φ_mapsto [of y "G x"] by fastforce
hence "Ψ.FUN (y, x) (φD (y, G x) h) ∈ HomC.set (F y, x)"
using h x Ψ_Fun_mapsto by auto
thus ?thesis
using x h 1 ψ_def HomD.φ_mapsto HomC.ψ_mapsto [of "F y" x] by fastforce
qed
qed
lemma Ψ_simp:
assumes "D.ide y" and "C.ide x"
shows "S.arr (Ψ (y, x))"
and "Ψ (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(φC (F y, x) o ψ x o ψD (y, G x))"
proof -
show 1: "S.arr (Ψ (y, x))" using assms by auto
hence "Ψ (y, x) = S.mkArr (Ψ.DOM (y, x)) (Ψ.COD (y, x)) (Ψ.FUN (y, x))"
using S.mkArr_Fun by metis
also have "... = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x)) (Ψ.FUN (y, x))"
using assms HomC.set_map HomD.set_map by auto
also have "... = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(φC (F y, x) o ψ x o ψD (y, G x))"
proof (intro S.mkArr_eqI')
show "S.arr (S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x)) (Ψ.FUN (y, x)))"
using 1 calculation by argo
show "⋀h. h ∈ HomD.set (y, G x) ⟹
Ψ.FUN (y, x) h = (φC (F y, x) o ψ x o ψD (y, G x)) h"
proof -
fix h
assume h: "h ∈ HomD.set (y, G x)"
hence "«ψD (y, G x) h : y →⇩D G x»"
using assms HomD.ψ_mapsto [of y "G x"] by auto
hence "(φC (F y, x) o ψ x o HomD.ψ (y, G x)) h =
φC (F y, x) (ψC (F y, x) (Ψ.FUN (y, x) (φD (y, G x) (ψD (y, G x) h))))"
using h ψ_def by auto
also have "... = φC (F y, x) (ψC (F y, x) (Ψ.FUN (y, x) h))"
using assms h HomD.φ_ψ Ψ_Fun_mapsto by simp
also have "... = Ψ.FUN (y, x) h"
using assms h Ψ_Fun_mapsto HomD.ψ_mapsto [of y "G x"] HomC.φ_ψ [of "F y" x]
C.ide_in_hom D.ide_in_hom
by blast
finally show "Ψ.FUN (y, x) h = (φC (F y, x) o ψ x o HomD.ψ (y, G x)) h" by auto
qed
qed
finally show "Ψ (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(φC (F y, x) o ψ x o ψD (y, G x))"
by force
qed
text‹
The length of the next proof stems from having to use properties of composition
of arrows in @{term[source=true] S} to infer properties of the composition of the
corresponding functions.
›
interpretation φψ: meta_adjunction C D F G φ ψ
proof
fix y :: 'd and x :: 'c and h :: 'c
assume y: "D.ide y" and h: "«h : F y →⇩C x»"
have x: "C.ide x" using h by auto
show "«φ y h : y →⇩D G x»"
proof -
have "Φ.FUN (y, x) ∈ HomC.set (F y, x) → HomD.set (y, G x)"
using y h Φ_Fun_mapsto by blast
thus ?thesis
using x y h φ_def HomD.ψ_mapsto [of y "G x"] HomC.φ_mapsto [of "F y" x] by auto
qed
show "ψ x (φ y h) = h"
proof -
have 0: "restrict (λh. h) (HomC.set (F y, x))
= restrict (φC (F y, x) o (ψ x o φ y) o ψC (F y, x)) (HomC.set (F y, x))"
proof -
have 1: "S.ide (Ψ (y, x) ⋅⇩S Φ (y, x))"
using x y ΦΨ.inv [of "(y, x)"] by auto
hence 6: "S.seq (Ψ (y, x)) (Φ (y, x))" by auto
have 2: "Φ (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(φD (y, G x) o φ y o ψC (F y, x)) ∧
Ψ (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(φC (F y, x) o ψ x o ψD (y, G x))"
using x y Φ_simp Ψ_simp by force
have 3: "S (Ψ (y, x)) (Φ (y, x))
= S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
(φC (F y, x) o (ψ x o φ y) o ψC (F y, x))"
proof -
have 4: "S.arr (Ψ (y, x) ⋅⇩S Φ (y, x))" using 1 by auto
hence "S (Ψ (y, x)) (Φ (y, x))
= S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
((φC (F y, x) o ψ x o ψD (y, G x))
o (φD (y, G x) o φ y o ψC (F y, x)))"
using 1 2 S.ide_in_hom S.comp_mkArr by fastforce
also have "... = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
(φC (F y, x) o (ψ x o φ y) o ψC (F y, x))"
proof (intro S.mkArr_eqI')
show "S.arr (S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
((φC (F y, x) o ψ x o ψD (y, G x))
o (φD (y, G x) o φ y o ψC (F y, x))))"
using 4 calculation by simp
show "⋀h. h ∈ HomC.set (F y, x) ⟹
((φC (F y, x) o ψ x o ψD (y, G x))
o (φD (y, G x) o φ y o ψC (F y, x))) h =
(φC (F y, x) o (ψ x o φ y) o ψC (F y, x)) h"
proof -
fix h
assume h: "h ∈ HomC.set (F y, x)"
hence 1: "«φ y (ψC (F y, x) h) : y →⇩D G x»"
using x y h HomC.ψ_mapsto [of "F y" x] φ_mapsto by auto
show "((φC (F y, x) o ψ x o ψD (y, G x))
o (φD (y, G x) o φ y o ψC (F y, x))) h =
(φC (F y, x) o (ψ x o φ y) o ψC (F y, x)) h"
using x y 1 φ_mapsto HomD.ψ_φ by simp
qed
qed
finally show ?thesis by simp
qed
moreover have "Ψ (y, x) ⋅⇩S Φ (y, x)
= S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x)) (λh. h)"
proof -
have "Ψ (y, x) ⋅⇩S Φ (y, x) = S.dom (S (Ψ (y, x)) (Φ (y, x)))"
using 1 by auto
also have "... = S.dom (Φ (y, x))"
using 1 S.dom_comp by blast
finally show ?thesis
using 2 6 S.mkIde_as_mkArr S.arr_mkArr by (elim S.seqE, auto)
qed
ultimately have 4: "S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
(φC (F y, x) o (ψ x o φ y) o ψC (F y, x))
= S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x)) (λh. h)"
by auto
have 5: "S.arr (S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
(φC (F y, x) o (ψ x o φ y) o ψC (F y, x)))"
proof -
have "S.seq (Ψ (y, x)) (Φ (y, x))"
using 1 by fast
thus ?thesis using 3 by metis
qed
hence "restrict (φC (F y, x) o (ψ x o φ y) o ψC (F y, x)) (HomC.set (F y, x))
= S.Fun (S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
(φC (F y, x) o (ψ x o φ y) o ψC (F y, x)))"
by auto
also have "... = restrict (λh. h) (HomC.set (F y, x))"
using 4 5 by auto
finally show ?thesis by auto
qed
moreover have "φC (F y, x) h ∈ HomC.set (F y, x)"
using x y h HomC.φ_mapsto [of "F y" x] by auto
ultimately have
"φC (F y, x) h = (φC (F y, x) o (ψ x o φ y) o ψC (F y, x)) (φC (F y, x) h)"
using x y h HomC.φ_mapsto [of "F y" x] by fast
hence "ψC (F y, x) (φC (F y, x) h) =
ψC (F y, x) ((φC (F y, x) o (ψ x o φ y) o ψC (F y, x)) (φC (F y, x) h))"
by simp
hence "h = ψC (F y, x) (φC (F y, x) (ψ x (φ y (ψC (F y, x) (φC (F y, x) h)))))"
using x y h HomC.ψ_φ [of "F y" x] by simp
also have "... = ψ x (φ y h)"
using x y h HomC.ψ_φ HomC.ψ_φ φ_mapsto ψ_mapsto
by (metis PiE mem_Collect_eq)
finally show ?thesis by auto
qed
next
fix x :: 'c and h :: 'd and y :: 'd
assume x: "C.ide x" and h: "«h : y →⇩D G x»"
have y: "D.ide y" using h by auto
show "«ψ x h : F y →⇩C x»" using x y h ψ_mapsto [of x y] by auto
show "φ y (ψ x h) = h"
proof -
have 0: "restrict (λh. h) (HomD.set (y, G x))
= restrict (φD (y, G x) o (φ y o ψ x) o ψD (y, G x)) (HomD.set (y, G x))"
proof -
have 1: "S.ide (S (Φ (y, x)) (Ψ (y, x)))"
using x y ΦΨ.inv by force
hence 6: "S.seq (Φ (y, x)) (Ψ (y, x))" by auto
have 2: "Φ (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(φD (y, G x) o φ y o ψC (F y, x)) ∧
Ψ (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(φC (F y, x) o ψ x o ψD (y, G x))"
using x h Φ_simp Ψ_simp by auto
have 3: "S (Φ (y, x)) (Ψ (y, x))
= S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
(φD (y, G x) o (φ y o ψ x) o ψD (y, G x))"
proof -
have 4: "S.seq (Φ (y, x)) (Ψ (y, x))" using 1 by auto
hence "S (Φ (y, x)) (Ψ (y, x))
= S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
((φD (y, G x) o φ y o ψC (F y, x))
o (φC (F y, x) o ψ x o ψD (y, G x)))"
using 1 2 6 S.ide_in_hom S.comp_mkArr by fastforce
also have "... = S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
(φD (y, G x) o (φ y o ψ x) o ψD (y, G x))"
proof
show "S.arr (S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
((φD (y, G x) o φ y o ψC (F y, x))
o (φC (F y, x) o ψ x o ψD (y, G x))))"
using 4 calculation by simp
show "⋀h. h ∈ HomD.set (y, G x) ⟹
((φD (y, G x) o φ y o ψC (F y, x))
o (φC (F y, x) o ψ x o ψD (y, G x))) h =
(φD (y, G x) o (φ y o ψ x) o ψD (y, G x)) h"
proof -
fix h
assume h: "h ∈ HomD.set (y, G x)"
hence "«ψ x (ψD (y, G x) h) : F y →⇩C x»"
using x y HomD.ψ_mapsto [of y "G x"] ψ_mapsto by auto
thus "((φD (y, G x) o φ y o ψC (F y, x))
o (φC (F y, x) o ψ x o ψD (y, G x))) h =
(φD (y, G x) o (φ y o ψ x) o ψD (y, G x)) h"
using x y HomC.ψ_φ by simp
qed
qed
finally show ?thesis by auto
qed
moreover have "Φ (y, x) ⋅⇩S Ψ (y, x) =
S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x)) (λh. h)"
proof -
have "Φ (y, x) ⋅⇩S Ψ (y, x) = S.dom (Φ (y, x) ⋅⇩S Ψ (y, x))"
using 1 by auto
also have "... = S.dom (Ψ (y, x))"
using 1 S.dom_comp by blast
finally show ?thesis
using 2 6 S.mkIde_as_mkArr S.arr_mkArr
by (elim S.seqE, auto)
qed
ultimately have 4: "S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
(φD (y, G x) o (φ y o ψ x) o ψD (y, G x))
= S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x)) (λh. h)"
by auto
have 5: "S.arr (S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
(φD (y, G x) o (φ y o ψ x) o ψD (y, G x)))"
using 1 3 by fastforce
hence "restrict (φD (y, G x) o (φ y o ψ x) o ψD (y, G x)) (HomD.set (y, G x))
= S.Fun (S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
(φD (y, G x) o (φ y o ψ x) o ψD (y, G x)))"
by auto
also have "... = restrict (λh. h) (HomD.set (y, G x))"
using 4 5 by auto
finally show ?thesis by auto
qed
moreover have "φD (y, G x) h ∈ HomD.set (y, G x)"
using x y h HomD.φ_mapsto [of y "G x"] by auto
ultimately have
"φD (y, G x) h = (φD (y, G x) o (φ y o ψ x) o ψD (y, G x)) (φD (y, G x) h)"
by fast
hence "ψD (y, G x) (φD (y, G x) h) =
ψD (y, G x) ((φD (y, G x) o (φ y o ψ x) o ψD (y, G x)) (φD (y, G x) h))"
by simp
hence "h = ψD (y, G x) (φD (y, G x) (φ y (ψ x (ψD (y, G x) (φD (y, G x) h)))))"
using x y h HomD.ψ_φ by simp
also have "... = φ y (ψ x h)"
using x y h HomD.ψ_φ HomD.ψ_φ [of "φ y (ψ x h)" y "G x"] φ_mapsto ψ_mapsto
by fastforce
finally show ?thesis by auto
qed
next
fix x :: 'c and x' :: 'c and y :: 'd and y' :: 'd
and f :: 'c and g :: 'd and h :: 'c
assume f: "«f : x →⇩C x'»" and g: "«g : y' →⇩D y»" and h: "«h : F y →⇩C x»"
have x: "C.ide x" using f by auto
have y: "D.ide y" using g by auto
have x': "C.ide x'" using f by auto
have y': "D.ide y'" using g by auto
show "φ y' (f ⋅⇩C h ⋅⇩C F g) = G f ⋅⇩D φ y h ⋅⇩D g"
proof -
have 0: "restrict ((φD (y', G x') o (λh. G f ⋅⇩D h ⋅⇩D g) o ψD (y, G x))
o (φD (y, G x) o φ y o ψC (F y, x)))
(HomC.set (F y, x))
= restrict ((φD (y', G x') o φ y' o ψC (F y', x'))
o (φC (F y', x') o (λh. f ⋅⇩C h ⋅⇩C F g)) o ψC (F y, x))
(HomC.set (F y, x))"
proof -
have 1: "S.arr (Φ (y, x)) ∧
Φ (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(φD (y, G x) o φ y o ψC (F y, x))"
using x y Φ_simp [of y x] by auto
have 2: "S.arr (Φ (y', x')) ∧
Φ (y', x') = S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
(φD (y', G x') o φ y' o ψC (F y', x'))"
using x' y' Φ_simp [of y' x'] by auto
have 3: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((φD (y', G x') o (λh. G f ⋅⇩D h ⋅⇩D g) o ψD (y, G x))
o (φD (y, G x) o φ y o ψC (F y, x))))
∧ S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((φD (y', G x') o (λh. G f ⋅⇩D h ⋅⇩D g) o ψD (y, G x))
o (φD (y, G x) o φ y o ψC (F y, x)))
= S (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
(φD (y', G x') o (λh. G f ⋅⇩D h ⋅⇩D g) o ψD (y, G x)))
(S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(φD (y, G x) o φ y o ψC (F y, x)))"
proof -
have 1: "S.seq (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
(φD (y', G x') o (λh. G f ⋅⇩D h ⋅⇩D g) o ψD (y, G x)))
(S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(φD (y, G x) o φ y o ψC (F y, x)))"
proof -
have "S.arr (Hom_DopxG.map (g, f)) ∧
Hom_DopxG.map (g, f)
= S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
(φD (y', G x') o (λh. G f ⋅⇩D h ⋅⇩D g) o ψD (y, G x))"
using f g Hom_DopxG.preserves_arr Hom_DopxG_map_simp by fastforce
thus ?thesis
using 1 S.cod_mkArr S.dom_mkArr S.seqI by metis
qed
have "S.seq (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
(φD (y', G x') o (λh. G f ⋅⇩D h ⋅⇩D g) o ψD (y, G x)))
(S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(φD (y, G x) o φ y o ψC (F y, x)))"
using 1 by (intro S.seqI', auto)
moreover have "S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((φD (y', G x') o (λh. G f ⋅⇩D h ⋅⇩D g) o ψD (y, G x))
o (φD (y, G x) o φ y o ψC (F y, x)))
= S (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
(φD (y', G x') o (λh. G f ⋅⇩D h ⋅⇩D g) o ψD (y, G x)))
(S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(φD (y, G x) o φ y o ψC (F y, x)))"
using 1 S.comp_mkArr by fastforce
ultimately show ?thesis by auto
qed
moreover have
4: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((φD (y', G x') o φ y' o ψC (F y', x'))
o (φC (F y', x') o (λh. f ⋅⇩C h ⋅⇩C F g) o ψC (F y, x))))
∧ S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((φD (y', G x') o φ y' o ψC (F y', x'))
o (φC (F y', x') o (λh. f ⋅⇩C h ⋅⇩C F g) o ψC (F y, x)))
= S (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
(φD (y', G x') o φ y' o ψC (F y', x')))
(S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
(φC (F y', x') o (λh. f ⋅⇩C h ⋅⇩C F g) o ψC (F y, x)))"
proof -
have 5: "S.seq (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
(φD (y', G x') o φ y' o ψC (F y', x')))
(S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
(φC (F y', x') o (λh. f ⋅⇩C h ⋅⇩C F g) o ψC (F y, x)))"
proof -
have "S.arr (Hom_FopxC.map (g, f)) ∧
Hom_FopxC.map (g, f)
= S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
(φC (F y', x') o (λh. f ⋅⇩C h ⋅⇩C F g) o ψC (F y, x))"
using f g Hom_FopxC.preserves_arr Hom_FopxC_map_simp by fastforce
thus ?thesis using 2 S.cod_mkArr S.dom_mkArr S.seqI by metis
qed
have "S.seq (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
(φD (y', G x') o φ y' o ψC (F y', x')))
(S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
(φC (F y', x') o (λh. f ⋅⇩C h ⋅⇩C F g) o ψC (F y, x)))"
using 5 by (intro S.seqI', auto)
moreover have "S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((φD (y', G x') o φ y' o ψC (F y', x'))
o (φC (F y', x') o (λh. f ⋅⇩C h ⋅⇩C F g) o ψC (F y, x)))
= S (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
(φD (y', G x') o φ y' o ψC (F y', x')))
(S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
(φC (F y', x') o (λh. f ⋅⇩C h ⋅⇩C F g) o ψC (F y, x)))"
using 5 S.comp_mkArr by fastforce
ultimately show ?thesis by argo
qed
moreover have 2:
"S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((φD (y', G x') o (λh. G f ⋅⇩D h ⋅⇩D g) o ψD (y, G x))
o (φD (y, G x) o φ y o ψC (F y, x)))
= S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((φD (y', G x') o φ y' o ψC (F y', x'))
o (φC (F y', x') o (λh. f ⋅⇩C h ⋅⇩C F g) o ψC (F y, x)))"
proof -
have
"S (Hom_DopxG.map (g, f)) (Φ (y, x)) = S (Φ (y', x')) (Hom_FopxC.map (g, f))"
using f g Φ.is_natural_1 Φ.is_natural_2 by fastforce
moreover have "Hom_DopxG.map (g, f)
= S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
(φD (y', G x') o (λh. G f ⋅⇩D h ⋅⇩D g) o ψD (y, G x))"
using f g Hom_DopxG_map_simp [of "(g, f)"] by fastforce
moreover have "Hom_FopxC.map (g, f)
= S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
(φC (F y', x') o (λh. f ⋅⇩C h ⋅⇩C F g) o ψC (F y, x))"
using f g Hom_FopxC_map_simp [of "(g, f)"] by fastforce
ultimately show ?thesis using 1 2 3 4 by simp
qed
ultimately have 6: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((φD (y', G x') o (λh. G f ⋅⇩D h ⋅⇩D g) o ψD (y, G x))
o (φD (y, G x) o φ y o ψC (F y, x))))"
by fast
hence "restrict ((φD (y', G x') o (λh. D (G f) (D h g)) o ψD (y, G x))
o (φD (y, G x) o φ y o ψC (F y, x)))
(HomC.set (F y, x))
= S.Fun (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((φD (y', G x') o (λh. G f ⋅⇩D h ⋅⇩D g) o ψD (y, G x))
o (φD (y, G x) o φ y o ψC (F y, x))))"
by simp
also have "... = S.Fun (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
((φD (y', G x') o φ y' o ψC (F y', x'))
o (φC (F y', x') o (λh. f ⋅⇩C h ⋅⇩C F g) o ψC (F y, x))))"
using 2 by argo
also have "... = restrict ((φD (y', G x') o φ y' o ψC (F y', x'))
o (φC (F y', x') o (λh. f ⋅⇩C h ⋅⇩C F g) o ψC (F y, x)))
(HomC.set (F y, x))"
using 4 S.Fun_mkArr by meson
finally show ?thesis by auto
qed
hence 5: "((φD (y', G x') ∘ (λh. G f ⋅⇩D h ⋅⇩D g) ∘ ψD (y, G x))
∘ (φD (y, G x) ∘ φ y ∘ ψC (F y, x))) (φC (F y, x) h) =
(φD (y', G x') ∘ φ y' ∘ ψC (F y', x')
∘ (φC (F y', x') ∘ (λh. f ⋅⇩C h ⋅⇩C F g)) ∘ ψC (F y, x)) (φC (F y, x) h)"
proof -
have "φC (F y, x) h ∈ HomC.set (F y, x)"
using x y h HomC.φ_mapsto [of "F y" x] by auto
thus ?thesis
using 0 h restr_eqE [of "(φD (y', G x') ∘ (λh. G f ⋅⇩D h ⋅⇩D g) ∘ ψD (y, G x))
∘ (φD (y, G x) ∘ φ y ∘ ψC (F y, x))"
"HomC.set (F y, x)"
"(φD (y', G x') ∘ φ y' ∘ ψC (F y', x'))
∘ (φC (F y', x') ∘ (λh. f ⋅⇩C h ⋅⇩C F g) o ψC (F y, x))"]
by fast
qed
show ?thesis
proof -
have "φ y' (C f (C h (F g))) =
ψD (y', G x') (φD (y', G x') (φ y' (ψC (F y', x') (φC (F y', x')
(C f (C (ψC (F y, x) (φC (F y, x) h)) (F g)))))))"
proof -
have "ψD (y', G x') (φD (y', G x') (φ y' (ψC (F y', x') (φC (F y', x')
(C f (C (ψC (F y, x) (φC (F y, x) h)) (F g)))))))
= ψD (y', G x') (φD (y', G x') (φ y' (ψC (F y', x') (φC (F y', x')
(C f (C h (F g)))))))"
using x y h HomC.ψ_φ by simp
also have "... = ψD (y', G x') (φD (y', G x') (φ y' (C f (C h (F g)))))"
using f g h HomC.ψ_φ [of "C f (C h (F g))"] by fastforce
also have "... = φ y' (C f (C h (F g)))"
proof -
have "«φ y' (f ⋅⇩C h ⋅⇩C F g) : y' →⇩D G x'»"
using f g h y' x' φ_mapsto [of y' x'] by auto
thus ?thesis by simp
qed
finally show ?thesis by auto
qed
also have
"... = ψD (y', G x')
(φD (y', G x')
(G f ⋅⇩D ψD (y, G x) (φD (y, G x) (φ y (ψC (F y, x) (φC (F y, x) h))))
⋅⇩D g))"
using 5 by force
also have "... = D (G f) (D (φ y h) g)"
proof -
have φyh: "«φ y h : y →⇩D G x»"
using x y h φ_mapsto by auto
have "ψD (y', G x')
(φD (y', G x')
(G f ⋅⇩D ψD (y, G x) (φD (y, G x) (φ y (ψC (F y, x) (φC (F y, x) h))))
⋅⇩D g)) =
ψD (y', G x') (φD (y', G x') (G f ⋅⇩D ψD (y, G x) (φD (y, G x) (φ y h)) ⋅⇩D g))"
using x y f g h by auto
also have "... = ψD (y', G x') (φD (y', G x') (G f ⋅⇩D φ y h ⋅⇩D g))"
using φyh x' y' f g by simp
also have "... = G f ⋅⇩D φ y h ⋅⇩D g"
proof -
have "«G f ⋅⇩D φ y h ⋅⇩D g : y' →⇩D G x'»"
using x x' y' f g h φ_mapsto φyh by blast
thus ?thesis
using x y f g h φyh HomD.ψ_φ by auto
qed
finally show ?thesis by auto
qed
finally show ?thesis by auto
qed
qed
qed
theorem induces_meta_adjunction:
shows "meta_adjunction C D F G φ ψ" ..
end
section "Putting it All Together"
text‹
Combining the above results, an interpretation of any one of the locales:
‹left_adjoint_functor›, ‹right_adjoint_functor›, ‹meta_adjunction›,
‹hom_adjunction›, and ‹unit_counit_adjunction› extends to an interpretation
of ‹adjunction›.
›
context meta_adjunction
begin
interpretation F: left_adjoint_functor D C F using has_left_adjoint_functor by auto
interpretation G: right_adjoint_functor C D G using has_right_adjoint_functor by auto
interpretation ηε: unit_counit_adjunction C D F G η ε
using induces_unit_counit_adjunction η_def ε_def by auto
interpretation ΦΨ: hom_adjunction C D replete_setcat.comp φC φD F G Φ Ψ
using induces_hom_adjunction by auto
theorem induces_adjunction:
shows "adjunction C D replete_setcat.comp φC φD F G φ ψ η ε Φ Ψ"
apply (unfold_locales)
using ε_map_simp η_map_simp φ_in_terms_of_η φ_in_terms_of_Φ' ψ_in_terms_of_ε
ψ_in_terms_of_Ψ' Φ_simp Ψ_simp η_def ε_def
by auto
end
context unit_counit_adjunction
begin
interpretation φψ: meta_adjunction C D F G φ ψ using induces_meta_adjunction by auto
interpretation F: left_adjoint_functor D C F using φψ.has_left_adjoint_functor by auto
interpretation G: right_adjoint_functor C D G using φψ.has_right_adjoint_functor by auto
interpretation ΦΨ: hom_adjunction C D replete_setcat.comp
φψ.φC φψ.φD F G φψ.Φ φψ.Ψ
using φψ.induces_hom_adjunction by auto
theorem induces_adjunction:
shows "adjunction C D replete_setcat.comp φψ.φC φψ.φD F G φ ψ η ε φψ.Φ φψ.Ψ"
using ε_in_terms_of_ψ η_in_terms_of_φ φψ.φ_in_terms_of_Φ' ψ_def φψ.ψ_in_terms_of_Ψ'
φψ.Φ_simp φψ.Ψ_simp φ_def
apply (unfold_locales)
by auto
end
context hom_adjunction
begin
interpretation φψ: meta_adjunction C D F G φ ψ
using induces_meta_adjunction by auto
interpretation F: left_adjoint_functor D C F using φψ.has_left_adjoint_functor by auto
interpretation G: right_adjoint_functor C D G using φψ.has_right_adjoint_functor by auto
interpretation ηε: unit_counit_adjunction C D F G φψ.η φψ.ε
using φψ.induces_unit_counit_adjunction φψ.η_def φψ.ε_def by auto
theorem induces_adjunction:
shows "adjunction C D S φC φD F G φ ψ φψ.η φψ.ε Φ Ψ"
proof
fix x
assume "C.ide x"
thus "φψ.ε x = ψ x (G x)" using φψ.ε_map_simp φψ.ε_def by simp
next
fix y
assume "D.ide y"
thus "φψ.η y = φ y (F y)" using φψ.η_map_simp φψ.η_def by simp
fix x y f
assume y: "D.ide y" and f: "«f : F y →⇩C x»"
show "φ y f = G f ⋅⇩D φψ.η y" using y f φψ.φ_in_terms_of_η φψ.η_def by simp
show "φ y f = (ψD (y, G x) ∘ Φ.FUN (y, x) ∘ φC (F y, x)) f" using y f φ_def by auto
next
fix x y g
assume x: "C.ide x" and g: "«g : y →⇩D G x»"
show "ψ x g = φψ.ε x ⋅⇩C F g" using x g φψ.ψ_in_terms_of_ε φψ.ε_def by simp
show "ψ x g = (ψC (F y, x) ∘ Ψ.FUN (y, x) ∘ φD (y, G x)) g" using x g ψ_def by fast
next
fix x y
assume x: "C.ide x" and y: "D.ide y"
show "Φ (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
(φD (y, G x) o φ y o ψC (F y, x))"
using x y Φ_simp by simp
show "Ψ (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
(φC (F y, x) o ψ x o ψD (y, G x))"
using x y Ψ_simp by simp
qed
end
context left_adjoint_functor
begin
interpretation φψ: meta_adjunction C D F G φ ψ
using induces_meta_adjunction by auto
theorem induces_adjunction:
shows "adjunction C D replete_setcat.comp φψ.φC φψ.φD F G φ ψ φψ.η φψ.ε φψ.Φ φψ.Ψ"
using φψ.induces_adjunction by auto
end
context right_adjoint_functor
begin
interpretation φψ: meta_adjunction C D F G φ ψ
using induces_meta_adjunction by auto
theorem induces_adjunction:
shows "adjunction C D replete_setcat.comp φψ.φC φψ.φD F G φ ψ φψ.η φψ.ε φψ.Φ φψ.Ψ"
using φψ.induces_adjunction by auto
end
definition adjoint_functors
where "adjoint_functors C D F G = (∃φ ψ. meta_adjunction C D F G φ ψ)"
lemma adjoint_functors_respects_naturally_isomorphic:
assumes "adjoint_functors C D F G"
and "naturally_isomorphic D C F' F" and "naturally_isomorphic C D G G'"
shows "adjoint_functors C D F' G'"
proof -
obtain φ ψ where φψ: "meta_adjunction C D F G φ ψ"
using assms(1) adjoint_functors_def by blast
interpret φψ: meta_adjunction C D F G φ ψ
using φψ by simp
obtain τ where τ: "natural_isomorphism D C F' F τ"
using assms(2) naturally_isomorphic_def by blast
obtain μ where μ: "natural_isomorphism C D G G' μ"
using assms(3) naturally_isomorphic_def by blast
show ?thesis
using adjoint_functors_def τ μ φψ.respects_natural_isomorphism by blast
qed
lemma left_adjoint_functor_respects_naturally_isomorphic:
assumes "left_adjoint_functor D C F"
and "naturally_isomorphic D C F F'"
shows "left_adjoint_functor D C F'"
proof -
interpret F: left_adjoint_functor D C F
using assms(1) by simp
have 1: "meta_adjunction C D F F.G F.φ F.ψ"
using F.induces_meta_adjunction by simp
interpret φψ: meta_adjunction C D F F.G F.φ F.ψ
using 1 by simp
have "adjoint_functors C D F F.G"
using 1 adjoint_functors_def by blast
hence 2: "adjoint_functors C D F' F.G"
using assms(2) adjoint_functors_respects_naturally_isomorphic [of C D F F.G F' F.G]
naturally_isomorphic_reflexive naturally_isomorphic_symmetric
φψ.G.functor_axioms
by blast
obtain φ' ψ' where φ'ψ': "meta_adjunction C D F' F.G φ' ψ'"
using 2 adjoint_functors_def by blast
interpret φ'ψ': meta_adjunction C D F' F.G φ' ψ'
using φ'ψ' by simp
show ?thesis
using φ'ψ'.has_left_adjoint_functor by simp
qed
lemma right_adjoint_functor_respects_naturally_isomorphic:
assumes "right_adjoint_functor C D G"
and "naturally_isomorphic C D G G'"
shows "right_adjoint_functor C D G'"
proof -
interpret G: right_adjoint_functor C D G
using assms(1) by simp
have 1: "meta_adjunction C D G.F G G.φ G.ψ"
using G.induces_meta_adjunction by simp
interpret φψ: meta_adjunction C D G.F G G.φ G.ψ
using 1 by simp
have "adjoint_functors C D G.F G"
using 1 adjoint_functors_def by blast
hence 2: "adjoint_functors C D G.F G'"
using assms(2) adjoint_functors_respects_naturally_isomorphic
naturally_isomorphic_reflexive naturally_isomorphic_symmetric
φψ.F.functor_axioms
by blast
obtain φ' ψ' where φ'ψ': "meta_adjunction C D G.F G' φ' ψ'"
using 2 adjoint_functors_def by blast
interpret φ'ψ': meta_adjunction C D G.F G' φ' ψ'
using φ'ψ' by simp
show ?thesis
using φ'ψ'.has_right_adjoint_functor by simp
qed
section "Inverse Functors are Adjoints"
lemma inverse_functors_induce_meta_adjunction:
assumes "inverse_functors C D F G"
shows "meta_adjunction C D F G (λx. G) (λy. F)"
proof -
interpret inverse_functors C D F G using assms by auto
interpret meta_adjunction C D F G ‹λx. G› ‹λy. F›
proof -
have 1: "⋀y. B.arr y ⟹ G (F y) = y"
proof -
fix y
assume y: "B.arr y"
have "G (F y) = (G o F) y" by simp
thus "G (F y) = y" using y inv B.map_def by simp
qed
have 2: "⋀x. A.arr x ⟹ F (G x) = x"
proof -
fix x
assume x: "A.arr x"
have "F (G x) = (F o G) x" by simp
thus "F (G x) = x" using x inv' A.map_def by simp
qed
show "meta_adjunction C D F G (λx. G) (λy. F)"
proof
fix y f x
assume y: "B.ide y" and f: "«f : F y →⇩A x»"
show "«G f : y →⇩B G x»" using y f 1 G.preserves_hom by (elim A.in_homE, auto)
show "F (G f) = f" using f 2 by auto
next
fix x g y
assume x: "A.ide x" and g: "«g : y →⇩B G x»"
show "«F g : F y →⇩A x»" using x g 2 F.preserves_hom by (elim B.in_homE, auto)
show "G (F g) = g" using g 1 A.map_def by blast
next
fix f x x' g y' y h
assume f: "«f : x →⇩A x'»" and g: "«g : y' →⇩B y»" and h: "«h : F y →⇩A x»"
show "G (C f (C h (F g))) = D (G f) (D (G h) g)"
using f g h 1 2 inv inv' A.map_def B.map_def by (elim A.in_homE B.in_homE, auto)
qed
qed
show ?thesis ..
qed
lemma inverse_functors_are_adjoints:
assumes "inverse_functors A B F G"
shows "adjoint_functors A B F G"
using assms inverse_functors_induce_meta_adjunction adjoint_functors_def by fast
context inverse_functors
begin
lemma η_char:
shows "meta_adjunction.η B F (λx. G) = identity_functor.map B"
proof (intro eqI)
interpret meta_adjunction A B F G ‹λy. G› ‹λx. F›
using inverse_functors_induce_meta_adjunction inverse_functors_axioms by auto
interpret adjunction A B replete_setcat.comp φC φD F G ‹λy. G› ‹λx. F› η ε Φ Ψ
using induces_adjunction by simp
show "natural_transformation B B B.map GF.map η"
using η.natural_transformation_axioms by auto
show "natural_transformation B B B.map GF.map B.map"
proof -
have "natural_transformation B B B.map B.map B.map" ..
moreover have "GF.map = B.map" using inv by auto
ultimately show ?thesis by auto
qed
fix b
show "B.ide b ⟹ η b = B.map b"
proof -
assume b: "B.ide b"
have "η b = GF.map b" using b η_map_simp η_def by simp
also have "... = B.map b" using b inv B.map_def by simp
finally show "η b = B.map b" by auto
qed
qed
lemma ε_char:
shows "meta_adjunction.ε A F G (λy. F) = identity_functor.map A"
proof (intro eqI)
interpret meta_adjunction A B F G ‹λy. G› ‹λx. F›
using inverse_functors_induce_meta_adjunction inverse_functors_axioms by auto
interpret adjunction A B replete_setcat.comp φC φD F G ‹λy. G› ‹λx. F› η ε Φ Ψ
using induces_adjunction by simp
show "natural_transformation A A FG.map A.map ε"
using ε.natural_transformation_axioms by auto
show "natural_transformation A A FG.map A.map A.map"
proof -
have "natural_transformation A A A.map A.map A.map" ..
moreover have "FG.map = A.map" using inv' by auto
ultimately show ?thesis by auto
qed
fix a
show "A.ide a ⟹ ε a = A.map a"
proof -
assume a: "A.ide a"
have "ε a = FG.map a" using a ε_map_simp ε_def by simp
also have "... = A.map a" using a inv' A.map_def by simp
finally show "ε a = A.map a" by auto
qed
qed
end
section "Composition of Adjunctions"
locale composite_adjunction =
A: category A +
B: category B +
C: category C +
F: "functor" B A F +
G: "functor" A B G +
F': "functor" C B F' +
G': "functor" B C G' +
FG: meta_adjunction A B F G φ ψ +
F'G': meta_adjunction B C F' G' φ' ψ'
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and C :: "'c comp" (infixr "⋅⇩C" 55)
and F :: "'b ⇒ 'a"
and G :: "'a ⇒ 'b"
and F' :: "'c ⇒ 'b"
and G' :: "'b ⇒ 'c"
and φ :: "'b ⇒ 'a ⇒ 'b"
and ψ :: "'a ⇒ 'b ⇒ 'a"
and φ' :: "'c ⇒ 'b ⇒ 'c"
and ψ' :: "'b ⇒ 'c ⇒ 'b"
begin
interpretation FG: adjunction A B replete_setcat.comp
FG.φC FG.φD F G φ ψ FG.η FG.ε FG.Φ FG.Ψ
using FG.induces_adjunction by simp
interpretation F'G': adjunction B C replete_setcat.comp F'G'.φC F'G'.φD F' G' φ' ψ'
F'G'.η F'G'.ε F'G'.Φ F'G'.Ψ
using F'G'.induces_adjunction by simp
lemma is_meta_adjunction:
shows "meta_adjunction A C (F o F') (G' o G) (λz. φ' z o φ (F' z)) (λx. ψ x o ψ' (G x))"
proof -
interpret G'oG: composite_functor A B C G G' ..
interpret FoF': composite_functor C B A F' F ..
show ?thesis
proof
fix y f x
assume y: "C.ide y" and f: "«f : FoF'.map y →⇩A x»"
show "«(φ' y ∘ φ (F' y)) f : y →⇩C G'oG.map x»"
using y f FG.φ_in_hom F'G'.φ_in_hom by simp
show "(ψ x ∘ ψ' (G x)) ((φ' y ∘ φ (F' y)) f) = f"
using y f FG.φ_in_hom F'G'.φ_in_hom FG.ψ_φ F'G'.ψ_φ by simp
next
fix x g y
assume x: "A.ide x" and g: "«g : y →⇩C G'oG.map x»"
show "«(ψ x ∘ ψ' (G x)) g : FoF'.map y →⇩A x»"
using x g FG.ψ_in_hom F'G'.ψ_in_hom by auto
show "(φ' y ∘ φ (F' y)) ((ψ x ∘ ψ' (G x)) g) = g"
using x g FG.ψ_in_hom F'G'.ψ_in_hom FG.φ_ψ F'G'.φ_ψ by simp
next
fix f x x' g y' y h
assume f: "«f : x →⇩A x'»" and g: "«g : y' →⇩C y»" and h: "«h : FoF'.map y →⇩A x»"
show "(φ' y' ∘ φ (F' y')) (f ⋅⇩A h ⋅⇩A FoF'.map g) =
G'oG.map f ⋅⇩C (φ' y ∘ φ (F' y)) h ⋅⇩C g"
using f g h FG.φ_naturality [of f x x' "F' g" "F' y'" "F' y" h]
F'G'.φ_naturality [of "G f" "G x" "G x'" g y' y "φ (F' y) h"]
FG.φ_in_hom
by fastforce
qed
qed
interpretation KηH: natural_transformation C C ‹G' o F'› ‹G' o G o F o F'›
‹G' o FG.η o F'›
proof -
interpret ηF': natural_transformation C B F' ‹(G o F) o F'› ‹FG.η o F'›
using FG.η_is_natural_transformation F'.natural_transformation_axioms
horizontal_composite
by fastforce
interpret G'ηF': natural_transformation C C ‹G' o F'› ‹G' o (G o F o F')›
‹G' o (FG.η o F')›
using ηF'.natural_transformation_axioms G'.natural_transformation_axioms
horizontal_composite
by blast
show "natural_transformation C C (G' o F') (G' o G o F o F') (G' o FG.η o F')"
using G'ηF'.natural_transformation_axioms o_assoc by metis
qed
interpretation G'ηF'oη': vertical_composite C C C.map ‹G' o F'› ‹G' o G o F o F'›
F'G'.η ‹G' o FG.η o F'› ..
interpretation FεG: natural_transformation A A ‹F o F' o G' o G› ‹F o G›
‹F o F'G'.ε o G›
proof -
interpret Fε': natural_transformation B A ‹F o (F' o G')› F ‹F o F'G'.ε›
using F'G'.ε.natural_transformation_axioms F.natural_transformation_axioms
horizontal_composite
by fastforce
interpret Fε'G: natural_transformation A A ‹F o (F' o G') o G› ‹F o G› ‹F o F'G'.ε o G›
using Fε'.natural_transformation_axioms G.natural_transformation_axioms
horizontal_composite
by blast
show "natural_transformation A A (F o F' o G' o G) (F o G) (F o F'G'.ε o G)"
using Fε'G.natural_transformation_axioms o_assoc by metis
qed
interpretation εoFε'G: vertical_composite A A ‹F ∘ F' ∘ G' ∘ G› ‹F o G› A.map
‹F o F'G'.ε o G› FG.ε ..
interpretation meta_adjunction A C ‹F o F'› ‹G' o G›
‹λz. φ' z o φ (F' z)› ‹λx. ψ x o ψ' (G x)›
using is_meta_adjunction by auto
interpretation adjunction A C replete_setcat.comp φC φD ‹F ∘ F'› ‹G' ∘ G›
‹λz. φ' z ∘ φ (F' z)› ‹λx. ψ x ∘ ψ' (G x)› η ε Φ Ψ
using induces_adjunction by simp
lemma η_char:
shows "η = G'ηF'oη'.map"
proof (intro NaturalTransformation.eqI)
show "natural_transformation C C C.map (G' o G o F o F') G'ηF'oη'.map" ..
show "natural_transformation C C C.map (G' o G o F o F') η"
proof -
have "natural_transformation C C C.map ((G' ∘ G) ∘ (F ∘ F')) η" ..
moreover have "(G' o G) o (F o F') = G' o G o F o F'" by auto
ultimately show ?thesis by metis
qed
fix a
assume a: "C.ide a"
show "η a = G'ηF'oη'.map a"
unfolding η_def
using a G'ηF'oη'.map_def FG.η.preserves_hom [of "F' a" "F' a" "F' a"]
F'G'.φ_in_terms_of_η FG.η_map_simp η_map_simp [of a] C.ide_in_hom
F'G'.η_def FG.η_def
by auto
qed
lemma ε_char:
shows "ε = εoFε'G.map"
proof (intro NaturalTransformation.eqI)
show "natural_transformation A A (F o F' o G' o G) A.map ε"
proof -
have "natural_transformation A A ((F ∘ F') ∘ (G' ∘ G)) A.map ε" ..
moreover have "(F o F') o (G' o G) = F o F' o G' o G" by auto
ultimately show ?thesis by metis
qed
show "natural_transformation A A (F ∘ F' ∘ G' ∘ G) A.map εoFε'G.map" ..
fix a
assume a: "A.ide a"
show "ε a = εoFε'G.map a"
proof -
have "ε a = ψ a (ψ' (G a) (G' (G a)))"
using a ε_in_terms_of_ψ by simp
also have "... = FG.ε a ⋅⇩A F (F'G'.ε (G a) ⋅⇩B F' (G' (G a)))"
unfolding ε_def
using a F'G'.ψ_in_terms_of_ε [of "G a" "G' (G a)" "G' (G a)"]
F'G'.ε.preserves_hom [of "G a" "G a" "G a"]
FG.ψ_in_terms_of_ε [of a "F'G'.ε (G a) ⋅⇩B F' (G' (G a))" "(F'G'.FG.map (G a))"]
F'G'.ε_def FG.ε_def
by fastforce
also have "... = εoFε'G.map a"
using a B.comp_arr_dom εoFε'G.map_def by simp
finally show ?thesis by blast
qed
qed
end
section "Right Adjoints are Unique up to Natural Isomorphism"
text‹
As an example of the use of the of the foregoing development, we show that two right adjoints
to the same functor are naturally isomorphic.
›
theorem two_right_adjoints_naturally_isomorphic:
assumes "adjoint_functors C D F G" and "adjoint_functors C D F G'"
shows "naturally_isomorphic C D G G'"
proof -
text‹
For any object @{term x} of @{term C}, we have that ‹ε x ∈ C.hom (F (G x)) x›
is a terminal arrow from @{term F} to @{term x}, and similarly for ‹ε' x›.
We may therefore obtain the unique coextension ‹τ x ∈ D.hom (G x) (G' x)›
of ‹ε x› along ‹ε' x›.
An explicit formula for ‹τ x› is ‹D (G' (ε x)) (η' (G x))›.
Similarly, we obtain ‹τ' x = D (G (ε' x)) (η (G' x)) ∈ D.hom (G' x) (G x)›.
We show these are the components of inverse natural transformations between
@{term G} and @{term G'}.
›
obtain φ ψ where φψ: "meta_adjunction C D F G φ ψ"
using assms adjoint_functors_def by blast
obtain φ' ψ' where φ'ψ': "meta_adjunction C D F G' φ' ψ'"
using assms adjoint_functors_def by blast
interpret Adj: meta_adjunction C D F G φ ψ using φψ by auto
interpret Adj: adjunction C D replete_setcat.comp Adj.φC Adj.φD
F G φ ψ Adj.η Adj.ε Adj.Φ Adj.Ψ
using Adj.induces_adjunction by auto
interpret Adj': meta_adjunction C D F G' φ' ψ' using φ'ψ' by auto
interpret Adj': adjunction C D replete_setcat.comp Adj'.φC Adj'.φD
F G' φ' ψ' Adj'.η Adj'.ε Adj'.Φ Adj'.Ψ
using Adj'.induces_adjunction by auto
write C (infixr "⋅⇩C" 55)
write D (infixr "⋅⇩D" 55)
write Adj.C.in_hom ("«_ : _ →⇩C _»")
write Adj.D.in_hom ("«_ : _ →⇩D _»")
let ?τo = "λa. G' (Adj.ε a) ⋅⇩D Adj'.η (G a)"
interpret τ: transformation_by_components C D G G' ?τo
proof
show "⋀a. Adj.C.ide a ⟹ «G' (Adj.ε a) ⋅⇩D Adj'.η (G a) : G a →⇩D G' a»"
by fastforce
show "⋀f. Adj.C.arr f ⟹
(G' (Adj.ε (Adj.C.cod f)) ⋅⇩D Adj'.η (G (Adj.C.cod f))) ⋅⇩D G f =
G' f ⋅⇩D G' (Adj.ε (Adj.C.dom f)) ⋅⇩D Adj'.η (G (Adj.C.dom f))"
proof -
fix f
assume f: "Adj.C.arr f"
let ?x = "Adj.C.dom f"
let ?x' = "Adj.C.cod f"
have "(G' (Adj.ε (Adj.C.cod f)) ⋅⇩D Adj'.η (G (Adj.C.cod f))) ⋅⇩D G f =
G' (Adj.ε (Adj.C.cod f) ⋅⇩C F (G f)) ⋅⇩D Adj'.η (G (Adj.C.dom f))"
using f Adj'.η.naturality [of "G f"] Adj.D.comp_assoc by simp
also have "... = G' (f ⋅⇩C Adj.ε (Adj.C.dom f)) ⋅⇩D Adj'.η (G (Adj.C.dom f))"
using f Adj.ε.naturality by simp
also have "... = G' f ⋅⇩D G' (Adj.ε (Adj.C.dom f)) ⋅⇩D Adj'.η (G (Adj.C.dom f))"
using f Adj.D.comp_assoc by simp
finally show "(G' (Adj.ε (Adj.C.cod f)) ⋅⇩D Adj'.η (G (Adj.C.cod f))) ⋅⇩D G f =
G' f ⋅⇩D G' (Adj.ε (Adj.C.dom f)) ⋅⇩D Adj'.η (G (Adj.C.dom f))"
by auto
qed
qed
interpret natural_isomorphism C D G G' τ.map
proof
fix a
assume a: "Adj.C.ide a"
show "Adj.D.iso (τ.map a)"
proof
show "Adj.D.inverse_arrows (τ.map a) (φ (G' a) (Adj'.ε a))"
proof
text‹
The proof that the two composites are identities is a modest diagram chase.
This is a good example of the inference rules for the ‹category›,
‹functor›, and ‹natural_transformation› locales in action.
Isabelle is able to use the single hypothesis that ‹a› is an identity to
implicitly fill in all the details that the various quantities are in fact arrows
and that the indicated composites are all well-defined, as well as to apply
associativity of composition. In most cases, this is done by auto or simp without
even mentioning any of the rules that are used.
$$\xymatrix{
{G' a} \ar[dd]_{\eta'(G'a)} \ar[rr]^{\tau' a} \ar[dr]_{\eta(G'a)}
&& {G a} \ar[rr]^{\tau a} \ar[dr]_{\eta'(Ga)} && {G' a} \\
& {GFG'a} \rrtwocell\omit{\omit(2)} \ar[ur]_{G(\epsilon' a)} \ar[dr]_{\eta'(GFG'a)}
&& {G'FGa} \drtwocell\omit{\omit(3)} \ar[ur]_{G'(\epsilon a)} & \\
{G'FG'a} \urtwocell\omit{\omit(1)} \ar[rr]_{G'F\eta(G'a)} \ar@/_8ex/[rrrr]_{G'FG'a}
&& {G'FGFG'a} \dtwocell\omit{\omit(4)} \ar[ru]_{G'FG(\epsilon' a)} \ar[rr]_{G'(\epsilon(FG'a))}
&& {G'FG'a} \ar[uu]_{G'(\epsilon' a)} \\
&&&&
}$$
›
show "Adj.D.ide (τ.map a ⋅⇩D φ (G' a) (Adj'.ε a))"
proof -
have "τ.map a ⋅⇩D φ (G' a) (Adj'.ε a) = G' a"
proof -
have "τ.map a ⋅⇩D φ (G' a) (Adj'.ε a) =
G' (Adj.ε a) ⋅⇩D (Adj'.η (G a) ⋅⇩D G (Adj'.ε a)) ⋅⇩D Adj.η (G' a)"
using a τ.map_simp_ide Adj.φ_in_terms_of_η Adj'.φ_in_terms_of_η
Adj'.ε.preserves_hom [of a a a] Adj.C.ide_in_hom Adj.D.comp_assoc
Adj.ε_def Adj.η_def
by simp
also have "... = G' (Adj.ε a) ⋅⇩D (G' (F (G (Adj'.ε a))) ⋅⇩D Adj'.η (G (F (G' a)))) ⋅⇩D
Adj.η (G' a)"
using a Adj'.η.naturality [of "G (Adj'.ε a)"] by auto
also have "... = (G' (Adj.ε a) ⋅⇩D G' (F (G (Adj'.ε a)))) ⋅⇩D G' (F (Adj.η (G' a))) ⋅⇩D
Adj'.η (G' a)"
using a Adj'.η.naturality [of "Adj.η (G' a)"] Adj.D.comp_assoc by auto
also have
"... = G' (Adj'.ε a) ⋅⇩D (G' (Adj.ε (F (G' a))) ⋅⇩D G' (F (Adj.η (G' a)))) ⋅⇩D
Adj'.η (G' a)"
proof -
have
"G' (Adj.ε a) ⋅⇩D G' (F (G (Adj'.ε a))) = G' (Adj'.ε a) ⋅⇩D G' (Adj.ε (F (G' a)))"
proof -
have "G' (Adj.ε a ⋅⇩C F (G (Adj'.ε a))) = G' (Adj'.ε a ⋅⇩C Adj.ε (F (G' a)))"
using a Adj.ε.naturality [of "Adj'.ε a"] by auto
thus ?thesis using a by force
qed
thus ?thesis using Adj.D.comp_assoc by auto
qed
also have "... = G' (Adj'.ε a) ⋅⇩D Adj'.η (G' a)"
proof -
have "G' (Adj.ε (F (G' a))) ⋅⇩D G' (F (Adj.η (G' a))) = G' (F (G' a))"
proof -
have
"G' (Adj.ε (F (G' a))) ⋅⇩D G' (F (Adj.η (G' a))) = G' (Adj.εFoFη.map (G' a))"
using a Adj.εFoFη.map_simp_1 by auto
moreover have "Adj.εFoFη.map (G' a) = F (G' a)"
using a by (simp add: Adj.ηε.triangle_F)
ultimately show ?thesis by auto
qed
thus ?thesis
using a Adj.D.comp_cod_arr [of "Adj'.η (G' a)"] by auto
qed
also have "... = G' a"
using a Adj'.ηε.triangle_G Adj'.GεoηG.map_simp_1 [of a] by auto
finally show ?thesis by auto
qed
thus ?thesis using a by simp
qed
show "Adj.D.ide (φ (G' a) (Adj'.ε a) ⋅⇩D τ.map a)"
proof -
have "φ (G' a) (Adj'.ε a) ⋅⇩D τ.map a = G a"
proof -
have "φ (G' a) (Adj'.ε a) ⋅⇩D τ.map a =
G (Adj'.ε a) ⋅⇩D (Adj.η (G' a) ⋅⇩D G' (Adj.ε a)) ⋅⇩D Adj'.η (G a)"
using a τ.map_simp_ide Adj.φ_in_terms_of_η Adj'.ε.preserves_hom [of a a a]
Adj.C.ide_in_hom Adj.D.comp_assoc Adj.η_def
by auto
also have
"... = G (Adj'.ε a) ⋅⇩D (G (F (G' (Adj.ε a))) ⋅⇩D Adj.η (G' (F (G a)))) ⋅⇩D
Adj'.η (G a)"
using a Adj.η.naturality [of "G' (Adj.ε a)"] by auto
also have
"... = (G (Adj'.ε a) ⋅⇩D G (F (G' (Adj.ε a)))) ⋅⇩D G (F (Adj'.η (G a))) ⋅⇩D
Adj.η (G a)"
using a Adj.η.naturality [of "Adj'.η (G a)"] Adj.D.comp_assoc by auto
also have
"... = G (Adj.ε a) ⋅⇩D (G (Adj'.ε (F (G a))) ⋅⇩D G (F (Adj'.η (G a)))) ⋅⇩D
Adj.η (G a)"
proof -
have "G (Adj'.ε a) ⋅⇩D G (F (G' (Adj.ε a))) = G (Adj.ε a) ⋅⇩D G (Adj'.ε (F (G a)))"
proof -
have "G (Adj'.ε a ⋅⇩C F (G' (Adj.ε a))) = G (Adj.ε a ⋅⇩C Adj'.ε (F (G a)))"
using a Adj'.ε.naturality [of "Adj.ε a"] by auto
thus ?thesis using a by force
qed
thus ?thesis using Adj.D.comp_assoc by auto
qed
also have "... = G (Adj.ε a) ⋅⇩D Adj.η (G a)"
proof -
have "G (Adj'.ε (F (G a))) ⋅⇩D G (F (Adj'.η (G a))) = G (F (G a))"
proof -
have
"G (Adj'.ε (F (G a))) ⋅⇩D G (F (Adj'.η (G a))) = G (Adj'.εFoFη.map (G a))"
using a Adj'.εFoFη.map_simp_1 [of "G a"] by auto
moreover have "Adj'.εFoFη.map (G a) = F (G a)"
using a by (simp add: Adj'.ηε.triangle_F)
ultimately show ?thesis by auto
qed
thus ?thesis
using a Adj.D.comp_cod_arr by auto
qed
also have "... = G a"
using a Adj.ηε.triangle_G Adj.GεoηG.map_simp_1 [of a] by auto
finally show ?thesis by auto
qed
thus ?thesis using a by auto
qed
qed
qed
qed
have "natural_isomorphism C D G G' τ.map" ..
thus "naturally_isomorphic C D G G'"
using naturally_isomorphic_def by blast
qed
end
Theory Limit
chapter Limit
theory Limit
imports FreeCategory DiscreteCategory Adjunction
begin
text‹
This theory defines the notion of limit in terms of diagrams and cones and relates
it to the concept of a representation of a functor. The diagonal functor associated
with a diagram shape @{term J} is defined and it is shown that a right adjoint to
the diagonal functor gives limits of shape @{term J} and that a category has limits
of shape @{term J} if and only if the diagonal functor is a left adjoint functor.
Products and equalizers are defined as special cases of limits, and it is shown
that a category with equalizers has limits of shape @{term J} if it has products
indexed by the sets of objects and arrows of @{term J}.
The existence of limits in a set category is investigated, and it is shown that
every set category has equalizers and that a set category @{term S} has @{term I}-indexed
products if and only if the universe of @{term S} ``admits @{term I}-indexed tupling.''
The existence of limits in functor categories is also developed, showing that
limits in functor categories are ``determined pointwise'' and that a functor category
@{term "[A, B]"} has limits of shape @{term J} if @{term B} does.
Finally, it is shown that the Yoneda functor preserves limits.
This theory concerns itself only with limits; I have made no attempt to consider colimits.
Although it would be possible to rework the entire development in dual form,
it is possible that there is a more efficient way to dualize at least parts of it without
repeating all the work. This is something that deserves further thought.
›
section "Representations of Functors"
text‹
A representation of a contravariant functor ‹F: Cop → S›, where @{term S}
is a replete set category that is the target of a hom-functor for @{term C}, consists of
an object @{term a} of @{term C} and a natural isomorphism @{term "Φ: Y a → F"},
where ‹Y: C → [Cop, S]› is the Yoneda functor.
›
locale representation_of_functor =
C: category C +
Cop: dual_category C +
S: replete_set_category S +
F: "functor" Cop.comp S F +
Hom: hom_functor C S φ +
Ya: yoneda_functor_fixed_object C S φ a +
natural_isomorphism Cop.comp S ‹Ya.Y a› F Φ
for C :: "'c comp" (infixr "⋅" 55)
and S :: "'s comp" (infixr "⋅⇩S" 55)
and φ :: "'c * 'c ⇒ 'c ⇒ 's"
and F :: "'c ⇒ 's"
and a :: 'c
and Φ :: "'c ⇒ 's"
begin
abbreviation Y where "Y ≡ Ya.Y"
abbreviation ψ where "ψ ≡ Hom.ψ"
end
text‹
Two representations of the same functor are uniquely isomorphic.
›
locale two_representations_one_functor =
C: category C +
Cop: dual_category C +
S: replete_set_category S +
F: set_valued_functor Cop.comp S F +
yoneda_functor C S φ +
Ya: yoneda_functor_fixed_object C S φ a +
Ya': yoneda_functor_fixed_object C S φ a' +
Φ: representation_of_functor C S φ F a Φ +
Φ': representation_of_functor C S φ F a' Φ'
for C :: "'c comp" (infixr "⋅" 55)
and S :: "'s comp" (infixr "⋅⇩S" 55)
and F :: "'c ⇒ 's"
and φ :: "'c * 'c ⇒ 'c ⇒ 's"
and a :: 'c
and Φ :: "'c ⇒ 's"
and a' :: 'c
and Φ' :: "'c ⇒ 's"
begin
interpretation Ψ: inverse_transformation Cop.comp S ‹Y a› F Φ ..
interpretation Ψ': inverse_transformation Cop.comp S ‹Y a'› F Φ' ..
interpretation ΦΨ': vertical_composite Cop.comp S ‹Y a› F ‹Y a'› Φ Ψ'.map ..
interpretation Φ'Ψ: vertical_composite Cop.comp S ‹Y a'› F ‹Y a› Φ' Ψ.map ..
lemma are_uniquely_isomorphic:
shows "∃!φ. «φ : a → a'» ∧ C.iso φ ∧ map φ = Cop_S.MkArr (Y a) (Y a') ΦΨ'.map"
proof -
have "natural_isomorphism Cop.comp S (Y a) F Φ" ..
moreover have "natural_isomorphism Cop.comp S F (Y a') Ψ'.map" ..
ultimately have 1: "natural_isomorphism Cop.comp S (Y a) (Y a') ΦΨ'.map"
using NaturalTransformation.natural_isomorphisms_compose by blast
interpret ΦΨ': natural_isomorphism Cop.comp S ‹Y a› ‹Y a'› ΦΨ'.map
using 1 by auto
have "natural_isomorphism Cop.comp S (Y a') F Φ'" ..
moreover have "natural_isomorphism Cop.comp S F (Y a) Ψ.map" ..
ultimately have 2: "natural_isomorphism Cop.comp S (Y a') (Y a) Φ'Ψ.map"
using NaturalTransformation.natural_isomorphisms_compose by blast
interpret Φ'Ψ: natural_isomorphism Cop.comp S ‹Y a'› ‹Y a› Φ'Ψ.map
using 2 by auto
interpret ΦΨ'_Φ'Ψ: inverse_transformations Cop.comp S ‹Y a› ‹Y a'› ΦΨ'.map Φ'Ψ.map
proof
fix x
assume X: "Cop.ide x"
show "S.inverse_arrows (ΦΨ'.map x) (Φ'Ψ.map x)"
proof
have 1: "S.arr (ΦΨ'.map x) ∧ ΦΨ'.map x = Ψ'.map x ⋅⇩S Φ x"
using X ΦΨ'.preserves_reflects_arr [of x]
by (simp add: ΦΨ'.map_simp_2)
have 2: "S.arr (Φ'Ψ.map x) ∧ Φ'Ψ.map x = Ψ.map x ⋅⇩S Φ' x"
using X Φ'Ψ.preserves_reflects_arr [of x]
by (simp add: Φ'Ψ.map_simp_1)
show "S.ide (ΦΨ'.map x ⋅⇩S Φ'Ψ.map x)"
using 1 2 X Ψ.is_natural_2 Ψ'.inverts_components Ψ.inverts_components
by (metis S.inverse_arrows_def S.inverse_arrows_compose)
show "S.ide (Φ'Ψ.map x ⋅⇩S ΦΨ'.map x)"
using 1 2 X Ψ'.inverts_components Ψ.inverts_components
by (metis S.inverse_arrows_def S.inverse_arrows_compose)
qed
qed
have "Cop_S.inverse_arrows (Cop_S.MkArr (Y a) (Y a') ΦΨ'.map)
(Cop_S.MkArr (Y a') (Y a) Φ'Ψ.map)"
proof -
have Ya: "functor Cop.comp S (Y a)" ..
have Ya': "functor Cop.comp S (Y a')" ..
have ΦΨ': "natural_transformation Cop.comp S (Y a) (Y a') ΦΨ'.map" ..
have Φ'Ψ: "natural_transformation Cop.comp S (Y a') (Y a) Φ'Ψ.map" ..
show ?thesis
proof (intro Cop_S.inverse_arrowsI)
have 0: "inverse_transformations Cop.comp S (Y a) (Y a') ΦΨ'.map Φ'Ψ.map" ..
have 1: "Cop_S.antipar (Cop_S.MkArr (Y a) (Y a') ΦΨ'.map)
(Cop_S.MkArr (Y a') (Y a) Φ'Ψ.map)"
using Ya Ya' ΦΨ' Φ'Ψ Cop_S.dom_char Cop_S.cod_char Cop_S.seqI
Cop_S.arr_MkArr Cop_S.cod_MkArr Cop_S.dom_MkArr
by presburger
show "Cop_S.ide (Cop_S.comp (Cop_S.MkArr (Y a) (Y a') ΦΨ'.map)
(Cop_S.MkArr (Y a') (Y a) Φ'Ψ.map))"
using 0 1 NaturalTransformation.inverse_transformations_inverse(2) Cop_S.comp_MkArr
by (metis Cop_S.cod_MkArr Cop_S.ide_char' Cop_S.seqE)
show "Cop_S.ide (Cop_S.comp (Cop_S.MkArr (Y a') (Y a) Φ'Ψ.map)
(Cop_S.MkArr (Y a) (Y a') ΦΨ'.map))"
using 0 1 NaturalTransformation.inverse_transformations_inverse(1) Cop_S.comp_MkArr
by (metis Cop_S.cod_MkArr Cop_S.ide_char' Cop_S.seqE)
qed
qed
hence 3: "Cop_S.iso (Cop_S.MkArr (Y a) (Y a') ΦΨ'.map)" using Cop_S.isoI by blast
hence "Cop_S.arr (Cop_S.MkArr (Y a) (Y a') ΦΨ'.map)" using Cop_S.iso_is_arr by blast
hence "Cop_S.in_hom (Cop_S.MkArr (Y a) (Y a') ΦΨ'.map) (map a) (map a')"
using Ya.ide_a Ya'.ide_a Cop_S.dom_char Cop_S.cod_char by auto
hence "∃f. «f : a → a'» ∧ map f = Cop_S.MkArr (Y a) (Y a') ΦΨ'.map"
using Ya.ide_a Ya'.ide_a is_full Y_def Cop_S.iso_is_arr full_functor.is_full
by auto
from this obtain φ
where φ: "«φ : a → a'» ∧ map φ = Cop_S.MkArr (Y a) (Y a') ΦΨ'.map"
by blast
from φ have "C.iso φ"
using 3 reflects_iso [of φ a a'] by simp
hence EX: "∃φ. «φ : a → a'» ∧ C.iso φ ∧ map φ = Cop_S.MkArr (Y a) (Y a') ΦΨ'.map"
using φ by blast
have
UN: "⋀φ'. «φ' : a → a'» ∧ map φ' = Cop_S.MkArr (Y a) (Y a') ΦΨ'.map ⟹ φ' = φ"
proof -
fix φ'
assume φ': "«φ' : a → a'» ∧ map φ' = Cop_S.MkArr (Y a) (Y a') ΦΨ'.map"
have "C.par φ φ' ∧ map φ = map φ'" using φ φ' by auto
thus "φ' = φ" using is_faithful by fast
qed
from EX UN show ?thesis by auto
qed
end
section "Diagrams and Cones"
text‹
A \emph{diagram} in a category @{term C} is a functor ‹D: J → C›.
We refer to the category @{term J} as the diagram \emph{shape}.
Note that in the usual expositions of category theory that use set theory
as their foundations, the shape @{term J} of a diagram is required to be
a ``small'' category, where smallness means that the collection of objects
of @{term J}, as well as each of the ``homs,'' is a set.
However, in HOL there is no class of all sets, so it is not meaningful
to speak of @{term J} as ``small'' in any kind of absolute sense.
There is likely a meaningful notion of smallness of @{term J}
\emph{relative to} @{term C} (the result below that states that a set
category has @{term I}-indexed products if and only if its universe
``admits @{term I}-indexed tuples'' is suggestive of how this might
be defined), but I haven't fully explored this idea at present.
›
locale diagram =
C: category C +
J: category J +
"functor" J C D
for J :: "'j comp" (infixr "⋅⇩J" 55)
and C :: "'c comp" (infixr "⋅" 55)
and D :: "'j ⇒ 'c"
begin
notation J.in_hom ("«_ : _ →⇩J _»")
end
lemma comp_diagram_functor:
assumes "diagram J C D" and "functor J' J F"
shows "diagram J' C (D o F)"
by (meson assms(1) assms(2) diagram_def functor.axioms(1) functor_comp)
text‹
A \emph{cone} over a diagram ‹D: J → C› is a natural transformation
from a constant functor to @{term D}. The value of the constant functor is
the \emph{apex} of the cone.
›
locale cone =
C: category C +
J: category J +
D: diagram J C D +
A: constant_functor J C a +
natural_transformation J C A.map D χ
for J :: "'j comp" (infixr "⋅⇩J" 55)
and C :: "'c comp" (infixr "⋅" 55)
and D :: "'j ⇒ 'c"
and a :: 'c
and χ :: "'j ⇒ 'c"
begin
lemma ide_apex:
shows "C.ide a"
using A.value_is_ide by auto
lemma component_in_hom:
assumes "J.arr j"
shows "«χ j : a → D (J.cod j)»"
using assms by auto
end
text‹
A cone over diagram @{term D} is transformed into a cone over diagram @{term "D o F"}
by pre-composing with @{term F}.
›
lemma comp_cone_functor:
assumes "cone J C D a χ" and "functor J' J F"
shows "cone J' C (D o F) a (χ o F)"
proof -
interpret χ: cone J C D a χ using assms(1) by auto
interpret F: "functor" J' J F using assms(2) by auto
interpret A': constant_functor J' C a
apply unfold_locales using χ.A.value_is_ide by auto
have 1: "χ.A.map o F = A'.map"
using χ.A.map_def A'.map_def χ.J.not_arr_null by auto
interpret χ': natural_transformation J' C A'.map ‹D o F› ‹χ o F›
using 1 horizontal_composite F.natural_transformation_axioms
χ.natural_transformation_axioms
by fastforce
show "cone J' C (D o F) a (χ o F)" ..
qed
text‹
A cone over diagram @{term D} can be transformed into a cone over a diagram @{term D'}
by post-composing with a natural transformation from @{term D} to @{term D'}.
›
lemma vcomp_transformation_cone:
assumes "cone J C D a χ"
and "natural_transformation J C D D' τ"
shows "cone J C D' a (vertical_composite.map J C χ τ)"
proof -
interpret χ: cone J C D a χ using assms(1) by auto
interpret τ: natural_transformation J C D D' τ using assms(2) by auto
interpret τoχ: vertical_composite J C χ.A.map D D' χ τ ..
interpret τoχ: cone J C D' a τoχ.map ..
show ?thesis ..
qed
context "functor"
begin
lemma preserves_diagrams:
fixes J :: "'j comp"
assumes "diagram J A D"
shows "diagram J B (F o D)"
proof -
interpret D: diagram J A D using assms by auto
interpret FoD: composite_functor J A B D F ..
show "diagram J B (F o D)" ..
qed
lemma preserves_cones:
fixes J :: "'j comp"
assumes "cone J A D a χ"
shows "cone J B (F o D) (F a) (F o χ)"
proof -
interpret χ: cone J A D a χ using assms by auto
interpret Fa: constant_functor J B ‹F a›
apply unfold_locales using χ.ide_apex by auto
have 1: "F o χ.A.map = Fa.map"
proof
fix f
show "(F ∘ χ.A.map) f = Fa.map f"
using is_extensional Fa.is_extensional χ.A.is_extensional
by (cases "χ.J.arr f", simp_all)
qed
interpret χ': natural_transformation J B Fa.map ‹F o D› ‹F o χ›
using 1 horizontal_composite χ.natural_transformation_axioms
natural_transformation_axioms
by fastforce
show "cone J B (F o D) (F a) (F o χ)" ..
qed
end
context diagram
begin
abbreviation cone
where "cone a χ ≡ Limit.cone J C D a χ"
abbreviation cones :: "'c ⇒ ('j ⇒ 'c) set"
where "cones a ≡ { χ. cone a χ }"
text‹
An arrow @{term "f ∈ C.hom a' a"} induces by composition a transformation from
cones with apex @{term a} to cones with apex @{term a'}. This transformation
is functorial in @{term f}.
›
abbreviation cones_map :: "'c ⇒ ('j ⇒ 'c) ⇒ ('j ⇒ 'c)"
where "cones_map f ≡ (λχ ∈ cones (C.cod f). λj. if J.arr j then χ j ⋅ f else C.null)"
lemma cones_map_mapsto:
assumes "C.arr f"
shows "cones_map f ∈
extensional (cones (C.cod f)) ∩ (cones (C.cod f) → cones (C.dom f))"
proof
show "cones_map f ∈ extensional (cones (C.cod f))" by blast
show "cones_map f ∈ cones (C.cod f) → cones (C.dom f)"
proof
fix χ
assume "χ ∈ cones (C.cod f)"
hence χ: "cone (C.cod f) χ" by auto
interpret χ: cone J C D ‹C.cod f› χ using χ by auto
interpret B: constant_functor J C ‹C.dom f›
apply unfold_locales using assms by auto
have "cone (C.dom f) (λj. if J.arr j then χ j ⋅ f else C.null)"
using assms B.value_is_ide χ.is_natural_1 χ.is_natural_2
apply (unfold_locales, auto)
using χ.is_natural_1
apply (metis C.comp_assoc)
using χ.is_natural_2 C.comp_arr_dom
by (metis J.arr_cod_iff_arr J.cod_cod C.comp_assoc)
thus "(λj. if J.arr j then χ j ⋅ f else C.null) ∈ cones (C.dom f)" by auto
qed
qed
lemma cones_map_ide:
assumes "χ ∈ cones a"
shows "cones_map a χ = χ"
proof -
interpret χ: cone J C D a χ using assms by auto
show ?thesis
proof
fix j
show "cones_map a χ j = χ j"
using assms χ.A.value_is_ide χ.preserves_hom C.comp_arr_dom χ.is_extensional
by (cases "J.arr j", auto)
qed
qed
lemma cones_map_comp:
assumes "C.seq f g"
shows "cones_map (f ⋅ g) = restrict (cones_map g o cones_map f) (cones (C.cod f))"
proof (intro restr_eqI)
show "cones (C.cod (f ⋅ g)) = cones (C.cod f)" using assms by simp
show "⋀χ. χ ∈ cones (C.cod (f ⋅ g)) ⟹
(λj. if J.arr j then χ j ⋅ f ⋅ g else C.null) = (cones_map g o cones_map f) χ"
proof -
fix χ
assume χ: "χ ∈ cones (C.cod (f ⋅ g))"
show "(λj. if J.arr j then χ j ⋅ f ⋅ g else C.null) = (cones_map g o cones_map f) χ"
proof -
have "((cones_map g) o (cones_map f)) χ = cones_map g (cones_map f χ)"
by force
also have "... = (λj. if J.arr j then
(λj. if J.arr j then χ j ⋅ f else C.null) j ⋅ g else C.null)"
proof
fix j
have "cone (C.dom f) (cones_map f χ)"
using assms χ cones_map_mapsto by (elim C.seqE, force)
thus "cones_map g (cones_map f χ) j =
(if J.arr j then C (if J.arr j then χ j ⋅ f else C.null) g else C.null)"
using χ assms by auto
qed
also have "... = (λj. if J.arr j then χ j ⋅ f ⋅ g else C.null)"
proof -
have "⋀j. J.arr j ⟹ (χ j ⋅ f) ⋅ g = χ j ⋅ f ⋅ g"
proof -
interpret χ: cone J C D ‹C.cod f› χ using assms χ by auto
fix j
assume j: "J.arr j"
show "(χ j ⋅ f) ⋅ g = χ j ⋅ f ⋅ g"
using assms C.comp_assoc by simp
qed
thus ?thesis by auto
qed
finally show ?thesis by auto
qed
qed
qed
end
text‹
Changing the apex of a cone by pre-composing with an arrow @{term f} commutes
with changing the diagram of a cone by post-composing with a natural transformation.
›
lemma cones_map_vcomp:
assumes "diagram J C D" and "diagram J C D'"
and "natural_transformation J C D D' τ"
and "cone J C D a χ"
and f: "partial_magma.in_hom C f a' a"
shows "diagram.cones_map J C D' f (vertical_composite.map J C χ τ)
= vertical_composite.map J C (diagram.cones_map J C D f χ) τ"
proof -
interpret D: diagram J C D using assms(1) by auto
interpret D': diagram J C D' using assms(2) by auto
interpret τ: natural_transformation J C D D' τ using assms(3) by auto
interpret χ: cone J C D a χ using assms(4) by auto
interpret τoχ: vertical_composite J C χ.A.map D D' χ τ ..
interpret τoχ: cone J C D' a τoχ.map ..
interpret χf: cone J C D a' ‹D.cones_map f χ›
using f χ.cone_axioms D.cones_map_mapsto by blast
interpret τoχf: vertical_composite J C χf.A.map D D' ‹D.cones_map f χ› τ ..
interpret τoχ_f: cone J C D' a' ‹D'.cones_map f τoχ.map›
using f τoχ.cone_axioms D'.cones_map_mapsto [of f] by blast
write C (infixr "⋅" 55)
show "D'.cones_map f τoχ.map = τoχf.map"
proof (intro NaturalTransformation.eqI)
show "natural_transformation J C χf.A.map D' (D'.cones_map f τoχ.map)" ..
show "natural_transformation J C χf.A.map D' τoχf.map" ..
show "⋀j. D.J.ide j ⟹ D'.cones_map f τoχ.map j = τoχf.map j"
proof -
fix j
assume j: "D.J.ide j"
have "D'.cones_map f τoχ.map j = τoχ.map j ⋅ f"
using f τoχ.cone_axioms τoχ.map_simp_2 τoχ.is_extensional by auto
also have "... = (τ j ⋅ χ (D.J.dom j)) ⋅ f"
using j τoχ.map_simp_2 by simp
also have "... = τ j ⋅ χ (D.J.dom j) ⋅ f"
using D.C.comp_assoc by simp
also have "... = τoχf.map j"
using j f χ.cone_axioms τoχf.map_simp_2 by auto
finally show "D'.cones_map f τoχ.map j = τoχf.map j" by auto
qed
qed
qed
text‹
Given a diagram @{term D}, we can construct a contravariant set-valued functor,
which takes each object @{term a} of @{term C} to the set of cones over @{term D}
with apex @{term a}, and takes each arrow @{term f} of @{term C} to the function
on cones over @{term D} induced by pre-composition with @{term f}.
For this, we need to introduce a set category @{term S} whose universe is large
enough to contain all the cones over @{term D}, and we need to have an explicit
correspondence between cones and elements of the universe of @{term S}.
A replete set category @{term S} equipped with an injective mapping
@{term_type "ι :: ('j => 'c) => 's"} serves this purpose.
›
locale cones_functor =
C: category C +
Cop: dual_category C +
J: category J +
D: diagram J C D +
S: replete_concrete_set_category S UNIV ι
for J :: "'j comp" (infixr "⋅⇩J" 55)
and C :: "'c comp" (infixr "⋅" 55)
and D :: "'j ⇒ 'c"
and S :: "'s comp" (infixr "⋅⇩S" 55)
and ι :: "('j ⇒ 'c) ⇒ 's"
begin
notation S.in_hom ("«_ : _ →⇩S _»")
abbreviation 𝗈 where "𝗈 ≡ S.𝗈"
definition map :: "'c ⇒ 's"
where "map = (λf. if C.arr f then
S.mkArr (ι ` D.cones (C.cod f)) (ι ` D.cones (C.dom f))
(ι o D.cones_map f o 𝗈)
else S.null)"
lemma map_simp [simp]:
assumes "C.arr f"
shows "map f = S.mkArr (ι ` D.cones (C.cod f)) (ι ` D.cones (C.dom f))
(ι o D.cones_map f o 𝗈)"
using assms map_def by auto
lemma arr_map:
assumes "C.arr f"
shows "S.arr (map f)"
proof -
have "ι o D.cones_map f o 𝗈 ∈ ι ` D.cones (C.cod f) → ι ` D.cones (C.dom f)"
using assms D.cones_map_mapsto by force
thus ?thesis using assms S.ι_mapsto S.arr_mkArr by auto
qed
lemma map_ide:
assumes "C.ide a"
shows "map a = S.mkIde (ι ` D.cones a)"
proof -
have "map a = S.mkArr (ι ` D.cones a) (ι ` D.cones a) (ι o D.cones_map a o 𝗈)"
using assms map_simp by force
also have "... = S.mkArr (ι ` D.cones a) (ι ` D.cones a) (λx. x)"
using S.ι_mapsto D.cones_map_ide S.arr_mkArr by force
also have "... = S.mkIde (ι ` D.cones a)"
using assms S.mkIde_as_mkArr S.ι_mapsto by blast
finally show ?thesis by auto
qed
lemma map_preserves_dom:
assumes "Cop.arr f"
shows "map (Cop.dom f) = S.dom (map f)"
using assms arr_map map_ide by auto
lemma map_preserves_cod:
assumes "Cop.arr f"
shows "map (Cop.cod f) = S.cod (map f)"
using assms arr_map map_ide by auto
lemma map_preserves_comp:
assumes "Cop.seq g f"
shows "map (g ⋅⇧o⇧p f) = map g ⋅⇩S map f"
proof -
have "map (g ⋅⇧o⇧p f) = S.mkArr (ι ` D.cones (C.cod f)) (ι ` D.cones (C.dom g))
((ι o D.cones_map g o 𝗈) o (ι o D.cones_map f o 𝗈))"
proof -
have 1: "S.arr (map (g ⋅⇧o⇧p f))"
using assms arr_map [of "C f g"] by simp
have "map (g ⋅⇧o⇧p f) = S.mkArr (ι ` D.cones (C.cod f)) (ι ` D.cones (C.dom g))
(ι o D.cones_map (C f g) o 𝗈)"
using assms map_simp [of "C f g"] by simp
also have "... = S.mkArr (ι ` D.cones (C.cod f)) (ι ` D.cones (C.dom g))
((ι o D.cones_map g o 𝗈) o (ι o D.cones_map f o 𝗈))"
using assms 1 calculation D.cones_map_mapsto D.cones_map_comp by auto
finally show ?thesis by blast
qed
also have "... = map g ⋅⇩S map f"
using assms arr_map [of f] arr_map [of g] map_simp S.comp_mkArr by auto
finally show ?thesis by auto
qed
lemma is_functor:
shows "functor Cop.comp S map"
apply (unfold_locales)
using map_def arr_map map_preserves_dom map_preserves_cod map_preserves_comp
by auto
end
sublocale cones_functor ⊆ "functor" Cop.comp S map using is_functor by auto
sublocale cones_functor ⊆ set_valued_functor Cop.comp S map ..
section Limits
subsection "Limit Cones"
text‹
A \emph{limit cone} for a diagram @{term D} is a cone @{term χ} over @{term D}
with the universal property that any other cone @{term χ'} over the diagram @{term D}
factors uniquely through @{term χ}.
›
locale limit_cone =
C: category C +
J: category J +
D: diagram J C D +
cone J C D a χ
for J :: "'j comp" (infixr "⋅⇩J" 55)
and C :: "'c comp" (infixr "⋅" 55)
and D :: "'j ⇒ 'c"
and a :: 'c
and χ :: "'j ⇒ 'c" +
assumes is_universal: "cone J C D a' χ' ⟹ ∃!f. «f : a' → a» ∧ D.cones_map f χ = χ'"
begin
definition induced_arrow :: "'c ⇒ ('j ⇒ 'c) ⇒ 'c"
where "induced_arrow a' χ' = (THE f. «f : a' → a» ∧ D.cones_map f χ = χ')"
lemma induced_arrowI:
assumes χ': "χ' ∈ D.cones a'"
shows "«induced_arrow a' χ' : a' → a»"
and "D.cones_map (induced_arrow a' χ') χ = χ'"
proof -
have "∃!f. «f : a' → a» ∧ D.cones_map f χ = χ'"
using assms χ' is_universal by simp
hence 1: "«induced_arrow a' χ' : a' → a» ∧ D.cones_map (induced_arrow a' χ') χ = χ'"
using theI' [of "λf. «f : a' → a» ∧ D.cones_map f χ = χ'"] induced_arrow_def
by presburger
show "«induced_arrow a' χ' : a' → a»" using 1 by simp
show "D.cones_map (induced_arrow a' χ') χ = χ'" using 1 by simp
qed
lemma cones_map_induced_arrow:
shows "induced_arrow a' ∈ D.cones a' → C.hom a' a"
and "⋀χ'. χ' ∈ D.cones a' ⟹ D.cones_map (induced_arrow a' χ') χ = χ'"
using induced_arrowI by auto
lemma induced_arrow_cones_map:
assumes "C.ide a'"
shows "(λf. D.cones_map f χ) ∈ C.hom a' a → D.cones a'"
and "⋀f. «f : a' → a» ⟹ induced_arrow a' (D.cones_map f χ) = f"
proof -
have a': "C.ide a'" using assms by (simp add: cone.ide_apex)
have cone_χ: "cone J C D a χ" ..
show "(λf. D.cones_map f χ) ∈ C.hom a' a → D.cones a'"
using cone_χ D.cones_map_mapsto by blast
fix f
assume f: "«f : a' → a»"
show "induced_arrow a' (D.cones_map f χ) = f"
proof -
have "D.cones_map f χ ∈ D.cones a'"
using f cone_χ D.cones_map_mapsto by blast
hence "∃!f'. «f' : a' → a» ∧ D.cones_map f' χ = D.cones_map f χ"
using assms is_universal by auto
thus ?thesis
using f induced_arrow_def
the1_equality [of "λf'. «f' : a' → a» ∧ D.cones_map f' χ = D.cones_map f χ"]
by presburger
qed
qed
text‹
For a limit cone @{term χ} with apex @{term a}, for each object @{term a'} the
hom-set @{term "C.hom a' a"} is in bijective correspondence with the set of cones
with apex @{term a'}.
›
lemma bij_betw_hom_and_cones:
assumes "C.ide a'"
shows "bij_betw (λf. D.cones_map f χ) (C.hom a' a) (D.cones a')"
proof (intro bij_betwI)
show "(λf. D.cones_map f χ) ∈ C.hom a' a → D.cones a'"
using assms induced_arrow_cones_map by blast
show "induced_arrow a' ∈ D.cones a' → C.hom a' a"
using assms cones_map_induced_arrow by blast
show "⋀f. f ∈ C.hom a' a ⟹ induced_arrow a' (D.cones_map f χ) = f"
using assms induced_arrow_cones_map by blast
show "⋀χ'. χ' ∈ D.cones a' ⟹ D.cones_map (induced_arrow a' χ') χ = χ'"
using assms cones_map_induced_arrow by blast
qed
lemma induced_arrow_eqI:
assumes "D.cone a' χ'" and "«f : a' → a»" and "D.cones_map f χ = χ'"
shows "induced_arrow a' χ' = f"
using assms is_universal induced_arrow_def
the1_equality [of "λf. f ∈ C.hom a' a ∧ D.cones_map f χ = χ'" f]
by simp
lemma induced_arrow_self:
shows "induced_arrow a χ = a"
proof -
have "«a : a → a» ∧ D.cones_map a χ = χ"
using ide_apex cone_axioms D.cones_map_ide by force
thus ?thesis using induced_arrow_eqI cone_axioms by auto
qed
end
context diagram
begin
abbreviation limit_cone
where "limit_cone a χ ≡ Limit.limit_cone J C D a χ"
text‹
A diagram @{term D} has object @{term a} as a limit if @{term a} is the apex
of some limit cone over @{term D}.
›
abbreviation has_as_limit :: "'c ⇒ bool"
where "has_as_limit a ≡ (∃χ. limit_cone a χ)"
abbreviation has_limit
where "has_limit ≡ (∃a χ. limit_cone a χ)"
definition some_limit :: 'c
where "some_limit = (SOME a. ∃χ. limit_cone a χ)"
definition some_limit_cone :: "'j ⇒ 'c"
where "some_limit_cone = (SOME χ. limit_cone some_limit χ)"
lemma limit_cone_some_limit_cone:
assumes has_limit
shows "limit_cone some_limit some_limit_cone"
proof -
have "∃a. has_as_limit a" using assms by simp
hence "has_as_limit some_limit"
using some_limit_def someI_ex [of "λa. ∃χ. limit_cone a χ"] by simp
thus "limit_cone some_limit some_limit_cone"
using assms some_limit_cone_def someI_ex [of "λχ. limit_cone some_limit χ"]
by simp
qed
lemma ex_limitE:
assumes "∃a. has_as_limit a"
obtains a χ where "limit_cone a χ"
using assms someI_ex by blast
end
subsection "Limits by Representation"
text‹
A limit for a diagram D can also be given by a representation ‹(a, Φ)›
of the cones functor.
›
locale representation_of_cones_functor =
C: category C +
Cop: dual_category C +
J: category J +
D: diagram J C D +
S: replete_concrete_set_category S UNIV ι +
Cones: cones_functor J C D S ι +
Hom: hom_functor C S φ +
representation_of_functor C S φ Cones.map a Φ
for J :: "'j comp" (infixr "⋅⇩J" 55)
and C :: "'c comp" (infixr "⋅" 55)
and D :: "'j ⇒ 'c"
and S :: "'s comp" (infixr "⋅⇩S" 55)
and φ :: "'c * 'c ⇒ 'c ⇒ 's"
and ι :: "('j ⇒ 'c) ⇒ 's"
and a :: 'c
and Φ :: "'c ⇒ 's"
subsection "Putting it all Together"
text‹
A ``limit situation'' combines and connects the ways of presenting a limit.
›
locale limit_situation =
C: category C +
Cop: dual_category C +
J: category J +
D: diagram J C D +
S: replete_concrete_set_category S UNIV ι +
Cones: cones_functor J C D S ι +
Hom: hom_functor C S φ +
Φ: representation_of_functor C S φ Cones.map a Φ +
χ: limit_cone J C D a χ
for J :: "'j comp" (infixr "⋅⇩J" 55)
and C :: "'c comp" (infixr "⋅" 55)
and D :: "'j ⇒ 'c"
and S :: "'s comp" (infixr "⋅⇩S" 55)
and φ :: "'c * 'c ⇒ 'c ⇒ 's"
and ι :: "('j ⇒ 'c) ⇒ 's"
and a :: 'c
and Φ :: "'c ⇒ 's"
and χ :: "'j ⇒ 'c" +
assumes χ_in_terms_of_Φ: "χ = S.𝗈 (S.Fun (Φ a) (φ (a, a) a))"
and Φ_in_terms_of_χ:
"Cop.ide a' ⟹ Φ a' = S.mkArr (Hom.set (a', a)) (ι ` D.cones a')
(λx. ι (D.cones_map (Hom.ψ (a', a) x) χ))"
text (in limit_situation) ‹
The assumption @{prop χ_in_terms_of_Φ} states that the universal cone @{term χ} is obtained
by applying the function @{term "S.Fun (Φ a)"} to the identity @{term a} of
@{term[source=true] C} (after taking into account the necessary coercions).
›
text (in limit_situation) ‹
The assumption @{prop Φ_in_terms_of_χ} states that the component of @{term Φ} at @{term a'}
is the arrow of @{term[source=true] S} corresponding to the function that takes an arrow
@{term "f ∈ C.hom a' a"} and produces the cone with vertex @{term a'} obtained
by transforming the universal cone @{term χ} by @{term f}.
›
subsection "Limit Cones Induce Limit Situations"
text‹
To obtain a limit situation from a limit cone, we need to introduce a set category
that is large enough to contain the hom-sets of @{term C} as well as the cones
over @{term D}. We use the category of all @{typ "('c + ('j ⇒ 'c))"}-sets for this.
›
context limit_cone
begin
interpretation Cop: dual_category C ..
interpretation CopxC: product_category Cop.comp C ..
interpretation S: replete_setcat ‹undefined :: 'c + ('j ⇒ 'c)› .
notation S.comp (infixr "⋅⇩S" 55)
interpretation Sr: replete_concrete_set_category S.comp UNIV ‹S.UP o Inr›
apply unfold_locales
using S.UP_mapsto
apply auto[1]
using S.inj_UP inj_Inr inj_compose
by metis
interpretation Cones: cones_functor J C D S.comp ‹S.UP o Inr› ..
interpretation Hom: hom_functor C S.comp ‹λ_. S.UP o Inl›
apply (unfold_locales)
using S.UP_mapsto
apply auto[1]
using S.inj_UP injD inj_onI inj_Inl inj_compose
by (metis (no_types, lifting))
interpretation Y: yoneda_functor C S.comp ‹λ_. S.UP o Inl› ..
interpretation Ya: yoneda_functor_fixed_object C S.comp ‹λ_. S.UP o Inl› a
apply (unfold_locales) using ide_apex by auto
abbreviation inl :: "'c ⇒ 'c + ('j ⇒ 'c)" where "inl ≡ Inl"
abbreviation inr :: "('j ⇒ 'c) ⇒ 'c + ('j ⇒ 'c)" where "inr ≡ Inr"
abbreviation ι where "ι ≡ S.UP o inr"
abbreviation 𝗈 where "𝗈 ≡ Cones.𝗈"
abbreviation φ where "φ ≡ λ_. S.UP o inl"
abbreviation ψ where "ψ ≡ Hom.ψ"
abbreviation Y where "Y ≡ Y.Y"
lemma Ya_ide:
assumes a': "C.ide a'"
shows "Y a a' = S.mkIde (Hom.set (a', a))"
using assms ide_apex Y.Y_simp Hom.map_ide by simp
lemma Ya_arr:
assumes g: "C.arr g"
shows "Y a g = S.mkArr (Hom.set (C.cod g, a)) (Hom.set (C.dom g, a))
(φ (C.dom g, a) o Cop.comp g o ψ (C.cod g, a))"
using ide_apex g Y.Y_ide_arr [of a g "C.dom g" "C.cod g"] by auto
lemma cone_χ [simp]:
shows "χ ∈ D.cones a"
using cone_axioms by simp
text‹
For each object @{term a'} of @{term[source=true] C} we have a function mapping
@{term "C.hom a' a"} to the set of cones over @{term D} with apex @{term a'},
which takes @{term "f ∈ C.hom a' a"} to ‹χf›, where ‹χf› is the cone obtained by
composing @{term χ} with @{term f} (after accounting for coercions to and from the
universe of @{term S}). The corresponding arrows of @{term S} are the
components of a natural isomorphism from @{term "Y a"} to ‹Cones›.
›
definition Φo :: "'c ⇒ ('c + ('j ⇒ 'c)) setcat.arr"
where
"Φo a' = S.mkArr (Hom.set (a', a)) (ι ` D.cones a') (λx. ι (D.cones_map (ψ (a', a) x) χ))"
lemma Φo_in_hom:
assumes a': "C.ide a'"
shows "«Φo a' : S.mkIde (Hom.set (a', a)) →⇩S S.mkIde (ι ` D.cones a')»"
proof -
have " «S.mkArr (Hom.set (a', a)) (ι ` D.cones a') (λx. ι (D.cones_map (ψ (a', a) x) χ)) :
S.mkIde (Hom.set (a', a)) →⇩S S.mkIde (ι ` D.cones a')»"
proof -
have "(λx. ι (D.cones_map (ψ (a', a) x) χ)) ∈ Hom.set (a', a) → ι ` D.cones a'"
proof
fix x
assume x: "x ∈ Hom.set (a', a)"
hence "«ψ (a', a) x : a' → a»"
using ide_apex a' Hom.ψ_mapsto by auto
hence "D.cones_map (ψ (a', a) x) χ ∈ D.cones a'"
using ide_apex a' x D.cones_map_mapsto cone_χ by force
thus "ι (D.cones_map (ψ (a', a) x) χ) ∈ ι ` D.cones a'" by simp
qed
moreover have "Hom.set (a', a) ⊆ S.Univ"
using ide_apex a' Hom.set_subset_Univ by auto
moreover have "ι ` D.cones a' ⊆ S.Univ"
using S.UP_mapsto by auto
ultimately show ?thesis using S.mkArr_in_hom by simp
qed
thus ?thesis using Φo_def [of a'] by auto
qed
interpretation Φ: transformation_by_components Cop.comp S.comp ‹Y a› Cones.map Φo
proof
fix a'
assume A': "Cop.ide a'"
show "«Φo a' : Y a a' →⇩S Cones.map a'»"
using A' Ya_ide Φo_in_hom Cones.map_ide by auto
next
fix g
assume g: "Cop.arr g"
show "Φo (Cop.cod g) ⋅⇩S Y a g = Cones.map g ⋅⇩S Φo (Cop.dom g)"
proof -
let ?A = "Hom.set (C.cod g, a)"
let ?B = "Hom.set (C.dom g, a)"
let ?B' = "ι ` D.cones (C.cod g)"
let ?C = "ι ` D.cones (C.dom g)"
let ?F = "φ (C.dom g, a) o Cop.comp g o ψ (C.cod g, a)"
let ?F' = "ι o D.cones_map g o 𝗈"
let ?G = "λx. ι (D.cones_map (ψ (C.dom g, a) x) χ)"
let ?G' = "λx. ι (D.cones_map (ψ (C.cod g, a) x) χ)"
have "S.arr (Y a g) ∧ Y a g = S.mkArr ?A ?B ?F"
using ide_apex g Ya.preserves_arr Ya_arr by fastforce
moreover have "S.arr (Φo (Cop.cod g))"
using g Φo_in_hom [of "Cop.cod g"] by auto
moreover have "Φo (Cop.cod g) = S.mkArr ?B ?C ?G"
using g Φo_def [of "C.dom g"] by auto
moreover have "S.seq (Φo (Cop.cod g)) (Y a g)"
using ide_apex g Φo_in_hom [of "Cop.cod g"] by auto
ultimately have 1: "S.seq (Φo (Cop.cod g)) (Y a g) ∧
Φo (Cop.cod g) ⋅⇩S Y a g = S.mkArr ?A ?C (?G o ?F)"
using S.comp_mkArr [of ?A ?B ?F ?C ?G] by argo
have "Cones.map g = S.mkArr (ι ` D.cones (C.cod g)) (ι ` D.cones (C.dom g)) ?F'"
using g Cones.map_simp by fastforce
moreover have "Φo (Cop.dom g) = S.mkArr ?A ?B' ?G'"
using g Φo_def by fastforce
moreover have "S.seq (Cones.map g) (Φo (Cop.dom g))"
using g Cones.preserves_hom [of g "C.cod g" "C.dom g"] Φo_in_hom [of "Cop.dom g"]
by force
ultimately have
2: "S.seq (Cones.map g) (Φo (Cop.dom g)) ∧
Cones.map g ⋅⇩S Φo (Cop.dom g) = S.mkArr ?A ?C (?F' o ?G')"
using S.seqI' [of "Φo (Cop.dom g)" "Cones.map g"] S.comp_mkArr by auto
have "Φo (Cop.cod g) ⋅⇩S Y a g = S.mkArr ?A ?C (?G o ?F)"
using 1 by auto
also have "... = S.mkArr ?A ?C (?F' o ?G')"
proof (intro S.mkArr_eqI')
show "S.arr (S.mkArr ?A ?C (?G o ?F))" using 1 by force
show "⋀x. x ∈ ?A ⟹ (?G o ?F) x = (?F' o ?G') x"
proof -
fix x
assume x: "x ∈ ?A"
hence 1: "«ψ (C.cod g, a) x : C.cod g → a»"
using ide_apex g Hom.ψ_mapsto [of "C.cod g" a] by auto
have "(?G o ?F) x = ι (D.cones_map (ψ (C.dom g, a)
(φ (C.dom g, a) (ψ (C.cod g, a) x ⋅ g))) χ)"
proof -
have "(?G o ?F) x = ?G (?F x)" by simp
also have "... = ι (D.cones_map (ψ (C.dom g, a)
(φ (C.dom g, a) (ψ (C.cod g, a) x ⋅ g))) χ)"
proof -
have "?F x = φ (C.dom g, a) (ψ (C.cod g, a) x ⋅ g)" by simp
thus ?thesis by presburger
qed
finally show ?thesis by auto
qed
also have "... = ι (D.cones_map (ψ (C.cod g, a) x ⋅ g) χ)"
proof -
have "«ψ (C.cod g, a) x ⋅ g : C.dom g → a»" using g 1 by auto
thus ?thesis using Hom.ψ_φ by presburger
qed
also have "... = ι (D.cones_map g (D.cones_map (ψ (C.cod g, a) x) χ))"
using g x 1 cone_χ D.cones_map_comp [of "ψ (C.cod g, a) x" g] by fastforce
also have "... = ι (D.cones_map g (𝗈 (ι (D.cones_map (ψ (C.cod g, a) x) χ))))"
using 1 cone_χ D.cones_map_mapsto Sr.𝗈_ι by auto
also have "... = (?F' o ?G') x" by simp
finally show "(?G o ?F) x = (?F' o ?G') x" by auto
qed
qed
also have "... = Cones.map g ⋅⇩S Φo (Cop.dom g)"
using 2 by auto
finally show ?thesis by auto
qed
qed
interpretation Φ: set_valued_transformation Cop.comp S.comp ‹Y a› Cones.map Φ.map ..
interpretation Φ: natural_isomorphism Cop.comp S.comp ‹Y a› Cones.map Φ.map
proof
fix a'
assume a': "Cop.ide a'"
show "S.iso (Φ.map a')"
proof -
let ?F = "λx. ι (D.cones_map (ψ (a', a) x) χ)"
have bij: "bij_betw ?F (Hom.set (a', a)) (ι ` D.cones a')"
proof -
have "⋀x x'. ⟦ x ∈ Hom.set (a', a); x' ∈ Hom.set (a', a);
ι (D.cones_map (ψ (a', a) x) χ) = ι (D.cones_map (ψ (a', a) x') χ) ⟧
⟹ x = x'"
proof -
fix x x'
assume x: "x ∈ Hom.set (a', a)" and x': "x' ∈ Hom.set (a', a)"
and xx': "ι (D.cones_map (ψ (a', a) x) χ) = ι (D.cones_map (ψ (a', a) x') χ)"
have ψx: "«ψ (a', a) x : a' → a»" using x ide_apex a' Hom.ψ_mapsto by auto
have ψx': "«ψ (a', a) x' : a' → a»" using x' ide_apex a' Hom.ψ_mapsto by auto
have 1: "∃!f. «f : a' → a» ∧ ι (D.cones_map f χ) = ι (D.cones_map (ψ (a', a) x) χ)"
proof -
have "D.cones_map (ψ (a', a) x) χ ∈ D.cones a'"
using ψx a' cone_χ D.cones_map_mapsto by force
hence 2: "∃!f. «f : a' → a» ∧ D.cones_map f χ = D.cones_map (ψ (a', a) x) χ"
using a' is_universal by simp
show "∃!f. «f : a' → a» ∧ ι (D.cones_map f χ) = ι (D.cones_map (ψ (a', a) x) χ)"
proof -
have "⋀f. ι (D.cones_map f χ) = ι (D.cones_map (ψ (a', a) x) χ)
⟷ D.cones_map f χ = D.cones_map (ψ (a', a) x) χ"
proof -
fix f :: 'c
have "D.cones_map f χ = D.cones_map (ψ (a', a) x) χ
⟶ ι (D.cones_map f χ) = ι (D.cones_map (ψ (a', a) x) χ)"
by simp
thus "(ι (D.cones_map f χ) = ι (D.cones_map (ψ (a', a) x) χ))
= (D.cones_map f χ = D.cones_map (ψ (a', a) x) χ)"
by (meson Sr.inj_ι injD)
qed
thus ?thesis using 2 by auto
qed
qed
have 2: "∃!x''. x'' ∈ Hom.set (a', a) ∧
ι (D.cones_map (ψ (a', a) x'') χ) = ι (D.cones_map (ψ (a', a) x) χ)"
proof -
from 1 obtain f'' where
f'': "«f'' : a' → a» ∧ ι (D.cones_map f'' χ) = ι (D.cones_map (ψ (a', a) x) χ)"
by blast
have "φ (a', a) f'' ∈ Hom.set (a', a) ∧
ι (D.cones_map (ψ (a', a) (φ (a', a) f'')) χ) = ι (D.cones_map (ψ (a', a) x) χ)"
proof
show "φ (a', a) f'' ∈ Hom.set (a', a)" using f'' Hom.set_def by auto
show "ι (D.cones_map (ψ (a', a) (φ (a', a) f'')) χ) =
ι (D.cones_map (ψ (a', a) x) χ)"
using f'' Hom.ψ_φ by presburger
qed
moreover have
"⋀x''. x'' ∈ Hom.set (a', a) ∧
ι (D.cones_map (ψ (a', a) x'') χ) = ι (D.cones_map (ψ (a', a) x) χ)
⟹ x'' = φ (a', a) f''"
proof -
fix x''
assume x'': "x'' ∈ Hom.set (a', a) ∧
ι (D.cones_map (ψ (a', a) x'') χ) = ι (D.cones_map (ψ (a', a) x) χ)"
hence "«ψ (a', a) x'' : a' → a» ∧
ι (D.cones_map (ψ (a', a) x'') χ) = ι (D.cones_map (ψ (a', a) x) χ)"
using ide_apex a' Hom.set_def Hom.ψ_mapsto [of a' a] by auto
hence "φ (a', a) (ψ (a', a) x'') = φ (a', a) f''"
using 1 f'' by auto
thus "x'' = φ (a', a) f''"
using ide_apex a' x'' Hom.φ_ψ by simp
qed
ultimately show ?thesis
using ex1I [of "λx'. x' ∈ Hom.set (a', a) ∧
ι (D.cones_map (ψ (a', a) x') χ) =
ι (D.cones_map (ψ (a', a) x) χ)"
"φ (a', a) f''"]
by simp
qed
thus "x = x'" using x x' xx' by auto
qed
hence "inj_on ?F (Hom.set (a', a))"
using inj_onI [of "Hom.set (a', a)" ?F] by auto
moreover have "?F ` Hom.set (a', a) = ι ` D.cones a'"
proof
show "?F ` Hom.set (a', a) ⊆ ι ` D.cones a'"
proof
fix X'
assume X': "X' ∈ ?F ` Hom.set (a', a)"
from this obtain x' where x': "x' ∈ Hom.set (a', a) ∧ ?F x' = X'" by blast
show "X' ∈ ι ` D.cones a'"
proof -
have "X' = ι (D.cones_map (ψ (a', a) x') χ)" using x' by blast
hence "X' = ι (D.cones_map (ψ (a', a) x') χ)" using x' by force
moreover have "«ψ (a', a) x' : a' → a»"
using ide_apex a' x' Hom.set_def Hom.ψ_φ by auto
ultimately show ?thesis
using x' cone_χ D.cones_map_mapsto by force
qed
qed
show "ι ` D.cones a' ⊆ ?F ` Hom.set (a', a)"
proof
fix X'
assume X': "X' ∈ ι ` D.cones a'"
hence "𝗈 X' ∈ 𝗈 ` ι ` D.cones a'" by simp
with Sr.𝗈_ι have "𝗈 X' ∈ D.cones a'"
by auto
hence "∃!f. «f : a' → a» ∧ D.cones_map f χ = 𝗈 X'"
using a' is_universal by simp
from this obtain f where "«f : a' → a» ∧ D.cones_map f χ = 𝗈 X'"
by auto
hence f: "«f : a' → a» ∧ ι (D.cones_map f χ) = X'"
using X' Sr.ι_𝗈 by auto
have "X' = ?F (φ (a', a) f)"
using f Hom.ψ_φ by presburger
thus "X' ∈ ?F ` Hom.set (a', a)"
using f Hom.set_def by force
qed
qed
ultimately show ?thesis
using bij_betw_def [of ?F "Hom.set (a', a)" "ι ` D.cones a'"] inj_on_def by auto
qed
let ?f = "S.mkArr (Hom.set (a', a)) (ι ` D.cones a') ?F"
have iso: "S.iso ?f"
proof -
have "?F ∈ Hom.set (a', a) → ι ` D.cones a'"
using bij bij_betw_imp_funcset by fast
hence 1: "S.arr ?f"
using ide_apex a' Hom.set_subset_Univ S.ι_mapsto S.arr_mkArr by auto
thus ?thesis using bij S.iso_char S.arr_mkArr S.set_mkIde by fastforce
qed
moreover have "?f = Φ.map a'"
using a' Φo_def by force
finally show ?thesis by auto
qed
qed
interpretation R: representation_of_functor C S.comp φ Cones.map a Φ.map ..
lemma χ_in_terms_of_Φ:
shows "χ = 𝗈 (Φ.FUN a (φ (a, a) a))"
proof -
have "Φ.FUN a (φ (a, a) a) =
(λx ∈ Hom.set (a, a). ι (D.cones_map (ψ (a, a) x) χ)) (φ (a, a) a)"
using ide_apex S.Fun_mkArr Φ.map_simp_ide Φo_def Φ.preserves_reflects_arr [of a]
by simp
also have "... = ι (D.cones_map a χ)"
proof -
have "φ (a, a) a ∈ Hom.set (a, a)"
using ide_apex Hom.φ_mapsto by fastforce
hence "(λx ∈ Hom.set (a, a). ι (D.cones_map (ψ (a, a) x) χ)) (φ (a, a) a)
= ι (D.cones_map (ψ (a, a) (φ (a, a) a)) χ)"
using restrict_apply' [of "φ (a, a) a" "Hom.set (a, a)"] by blast
also have "... = ι (D.cones_map a χ)"
proof -
have "ψ (a, a) (φ (a, a) a) = a"
using ide_apex Hom.ψ_φ [of a a a] by fastforce
thus ?thesis by metis
qed
finally show ?thesis by auto
qed
finally have "Φ.FUN a (φ (a, a) a) = ι (D.cones_map a χ)" by auto
also have "... = ι χ"
using ide_apex D.cones_map_ide [of χ a] cone_χ by simp
finally have "Φ.FUN a (φ (a, a) a) = ι χ" by blast
hence "𝗈 (Φ.FUN a (φ (a, a) a)) = 𝗈 (ι χ)" by simp
thus ?thesis using cone_χ Sr.𝗈_ι by simp
qed
abbreviation Hom
where "Hom ≡ Hom.map"
abbreviation Φ
where "Φ ≡ Φ.map"
lemma induces_limit_situation:
shows "limit_situation J C D S.comp φ ι a Φ χ"
proof
show "χ = 𝗈 (Φ.FUN a (φ (a, a) a))" using χ_in_terms_of_Φ by auto
fix a'
show "Cop.ide a' ⟹ Φ.map a' = S.mkArr (Hom.set (a', a)) (ι ` D.cones a')
(λx. ι (D.cones_map (ψ (a', a) x) χ))"
using Φ.map_simp_ide Φo_def [of a'] by force
qed
no_notation S.comp (infixr "⋅⇩S" 55)
end
sublocale limit_cone ⊆ limit_situation J C D replete_setcat.comp φ ι a Φ χ
using induces_limit_situation by auto
subsection "Representations of the Cones Functor Induce Limit Situations"
context representation_of_cones_functor
begin
interpretation Φ: set_valued_transformation Cop.comp S ‹Y a› Cones.map Φ ..
interpretation Ψ: inverse_transformation Cop.comp S ‹Y a› Cones.map Φ ..
interpretation Ψ: set_valued_transformation Cop.comp S Cones.map ‹Y a› Ψ.map ..
abbreviation 𝗈
where "𝗈 ≡ Cones.𝗈"
abbreviation χ
where "χ ≡ 𝗈 (S.Fun (Φ a) (φ (a, a) a))"
lemma Cones_SET_eq_ι_img_cones:
assumes "C.ide a'"
shows "Cones.SET a' = ι ` D.cones a'"
proof -
have "ι ` D.cones a' ⊆ S.Univ" using S.ι_mapsto by auto
thus ?thesis using assms Cones.map_ide S.set_mkIde by auto
qed
lemma ιχ:
shows "ι χ = S.Fun (Φ a) (φ (a, a) a)"
proof -
have "S.Fun (Φ a) (φ (a, a) a) ∈ Cones.SET a"
using Ya.ide_a Hom.φ_mapsto S.Fun_mapsto [of "Φ a"] Hom.set_map by fastforce
thus ?thesis
using Ya.ide_a Cones_SET_eq_ι_img_cones by auto
qed
interpretation χ: cone J C D a χ
proof -
have "ι χ ∈ ι ` D.cones a"
using Ya.ide_a ιχ S.Fun_mapsto [of "Φ a"] Hom.φ_mapsto Hom.set_map
Cones_SET_eq_ι_img_cones by fastforce
thus "D.cone a χ"
by (metis S.𝗈_ι UNIV_I imageE mem_Collect_eq)
qed
lemma cone_χ:
shows "D.cone a χ" ..
lemma Φ_FUN_simp:
assumes a': "C.ide a'" and x: "x ∈ Hom.set (a', a)"
shows "Φ.FUN a' x = Cones.FUN (ψ (a', a) x) (ι χ)"
proof -
have ψx: "«ψ (a', a) x : a' → a»"
using Ya.ide_a a' x Hom.ψ_mapsto by blast
have φa: "φ (a, a) a ∈ Hom.set (a, a)" using Ya.ide_a Hom.φ_mapsto by fastforce
have "Φ.FUN a' x = (Φ.FUN a' o Ya.FUN (ψ (a', a) x)) (φ (a, a) a)"
proof -
have "φ (a', a) (a ⋅ ψ (a', a) x) = x"
using Ya.ide_a a' x ψx Hom.φ_ψ C.comp_cod_arr by fastforce
moreover have "S.arr (S.mkArr (Hom.set (a, a)) (Hom.set (a', a))
(φ (a', a) ∘ Cop.comp (ψ (a', a) x) ∘ ψ (a, a)))"
by (metis (no_types) Cop.hom_char Ya.Y_ide_arr(2) Ya.preserves_reflects_arr
χ.ide_apex ψx Cop.in_homE)
ultimately show ?thesis
using Ya.ide_a a' x Ya.Y_ide_arr ψx φa C.ide_in_hom by auto
qed
also have "... = (Cones.FUN (ψ (a', a) x) o Φ.FUN a) (φ (a, a) a)"
proof -
have "(Φ.FUN a' o Ya.FUN (ψ (a', a) x)) (φ (a, a) a)
= S.Fun (Φ a' ⋅⇩S Y a (ψ (a', a) x)) (φ (a, a) a)"
using ψx a' φa Ya.ide_a Ya.map_simp Hom.set_map by (elim C.in_homE, auto)
also have "... = S.Fun (S (Cones.map (ψ (a', a) x)) (Φ a)) (φ (a, a) a)"
using ψx is_natural_1 [of "ψ (a', a) x"] is_natural_2 [of "ψ (a', a) x"] by auto
also have "... = (Cones.FUN (ψ (a', a) x) o Φ.FUN a) (φ (a, a) a)"
proof -
have "S.seq (Cones.map (ψ (a', a) x)) (Φ a)"
using Ya.ide_a ψx Cones.map_preserves_dom [of "ψ (a', a) x"]
apply (intro S.seqI)
apply auto[2]
by fastforce
thus ?thesis
using Ya.ide_a φa Hom.set_map by auto
qed
finally show ?thesis by simp
qed
also have "... = Cones.FUN (ψ (a', a) x) (ι χ)" using ιχ by simp
finally show ?thesis by auto
qed
lemma χ_is_universal:
assumes "D.cone a' χ'"
shows "«ψ (a', a) (Ψ.FUN a' (ι χ')) : a' → a»"
and "D.cones_map (ψ (a', a) (Ψ.FUN a' (ι χ'))) χ = χ'"
and "⟦ «f' : a' → a»; D.cones_map f' χ = χ' ⟧ ⟹ f' = ψ (a', a) (Ψ.FUN a' (ι χ'))"
proof -
interpret χ': cone J C D a' χ' using assms by auto
have a': "C.ide a'" using χ'.ide_apex by simp
have ιχ': "ι χ' ∈ Cones.SET a'" using assms a' Cones_SET_eq_ι_img_cones by auto
let ?f = "ψ (a', a) (Ψ.FUN a' (ι χ'))"
have A: "Ψ.FUN a' (ι χ') ∈ Hom.set (a', a)"
proof -
have "Ψ.FUN a' ∈ Cones.SET a' → Ya.SET a'"
using a' Ψ.preserves_hom [of a' a' a'] S.Fun_mapsto [of "Ψ.map a'"] by fastforce
thus ?thesis using a' ιχ' Ya.ide_a Hom.set_map by auto
qed
show f: "«?f : a' → a»" using A a' Ya.ide_a Hom.ψ_mapsto [of a' a] by auto
have E: "⋀f. «f : a' → a» ⟹ Cones.FUN f (ι χ) = Φ.FUN a' (φ (a', a) f)"
proof -
fix f
assume f: "«f : a' → a»"
have "φ (a', a) f ∈ Hom.set (a', a)"
using a' Ya.ide_a f Hom.φ_mapsto by auto
thus "Cones.FUN f (ι χ) = Φ.FUN a' (φ (a', a) f)"
using a' f Φ_FUN_simp by simp
qed
have I: "Φ.FUN a' (Ψ.FUN a' (ι χ')) = ι χ'"
proof -
have "Φ.FUN a' (Ψ.FUN a' (ι χ')) =
compose (Ψ.DOM a') (Φ.FUN a') (Ψ.FUN a') (ι χ')"
using a' ιχ' Cones.map_ide Ψ.preserves_hom [of a' a' a'] by force
also have "... = (λx ∈ Ψ.DOM a'. x) (ι χ')"
using a' Ψ.inverts_components S.inverse_arrows_char by force
also have "... = ι χ'"
using a' ιχ' Cones.map_ide Ψ.preserves_hom [of a' a' a'] by force
finally show ?thesis by auto
qed
show fχ: "D.cones_map ?f χ = χ'"
proof -
have "D.cones_map ?f χ = (𝗈 o Cones.FUN ?f o ι) χ"
using f Cones.preserves_arr [of ?f] cone_χ
by (cases "D.cone a χ", auto)
also have "... = χ'"
using f Ya.ide_a a' A E I by auto
finally show ?thesis by auto
qed
show "⟦ «f' : a' → a»; D.cones_map f' χ = χ' ⟧ ⟹ f' = ?f"
proof -
assume f': "«f' : a' → a»" and f'χ: "D.cones_map f' χ = χ'"
show "f' = ?f"
proof -
have 1: "φ (a', a) f' ∈ Hom.set (a', a) ∧ φ (a', a) ?f ∈ Hom.set (a', a)"
using Ya.ide_a a' f f' Hom.φ_mapsto by auto
have "S.iso (Φ a')" using χ'.ide_apex components_are_iso by auto
hence 2: "S.arr (Φ a') ∧ bij_betw (Φ.FUN a') (Hom.set (a', a)) (Cones.SET a')"
using Ya.ide_a a' S.iso_char Hom.set_map by auto
have "Φ.FUN a' (φ (a', a) f') = Φ.FUN a' (φ (a', a) ?f)"
proof -
have "Φ.FUN a' (φ (a', a) ?f) = ι χ'"
using A I Hom.φ_ψ Ya.ide_a a' by simp
also have "... = Cones.FUN f' (ι χ)"
using f f' A E cone_χ Cones.preserves_arr fχ f'χ by (elim C.in_homE, auto)
also have "... = Φ.FUN a' (φ (a', a) f')"
using f' E by simp
finally show ?thesis by argo
qed
moreover have "inj_on (Φ.FUN a') (Hom.set (a', a))"
using 2 bij_betw_imp_inj_on by blast
ultimately have 3: "φ (a', a) f' = φ (a', a) ?f"
using 1 inj_on_def [of "Φ.FUN a'" "Hom.set (a', a)"] by blast
show ?thesis
proof -
have "f' = ψ (a', a) (φ (a', a) f')"
using Ya.ide_a a' f' Hom.ψ_φ by simp
also have "... = ψ (a', a) (Ψ.FUN a' (ι χ'))"
using Ya.ide_a a' Hom.ψ_φ A 3 by simp
finally show ?thesis by blast
qed
qed
qed
qed
interpretation χ: limit_cone J C D a χ
proof
show "⋀a' χ'. D.cone a' χ' ⟹ ∃!f. «f : a' → a» ∧ D.cones_map f χ = χ'"
proof -
fix a' χ'
assume 1: "D.cone a' χ'"
show "∃!f. «f : a' → a» ∧ D.cones_map f χ = χ'"
proof
show "«ψ (a', a) (Ψ.FUN a' (ι χ')) : a' → a» ∧
D.cones_map (ψ (a', a) (Ψ.FUN a' (ι χ'))) χ = χ'"
using 1 χ_is_universal by blast
show "⋀f. «f : a' → a» ∧ D.cones_map f χ = χ' ⟹ f = ψ (a', a) (Ψ.FUN a' (ι χ'))"
using 1 χ_is_universal by blast
qed
qed
qed
lemma χ_is_limit_cone:
shows "D.limit_cone a χ" ..
lemma induces_limit_situation:
shows "limit_situation J C D S φ ι a Φ χ"
proof
show "χ = χ" by simp
fix a'
assume a': "Cop.ide a'"
let ?F = "λx. ι (D.cones_map (ψ (a', a) x) χ)"
show "Φ a' = S.mkArr (Hom.set (a', a)) (ι ` D.cones a') ?F"
proof -
have 1: "«Φ a' : S.mkIde (Hom.set (a', a)) →⇩S S.mkIde (ι ` D.cones a')»"
using a' Cones.map_ide Ya.ide_a by auto
moreover have "Φ.DOM a' = Hom.set (a', a)"
using 1 Hom.set_subset_Univ a' Ya.ide_a Hom.set_map by simp
moreover have "Φ.COD a' = ι ` D.cones a'"
using a' Cones_SET_eq_ι_img_cones by fastforce
ultimately have 2: "Φ a' = S.mkArr (Hom.set (a', a)) (ι ` D.cones a') (Φ.FUN a')"
using S.mkArr_Fun [of "Φ a'"] by fastforce
also have "... = S.mkArr (Hom.set (a', a)) (ι ` D.cones a') ?F"
proof
show "S.arr (S.mkArr (Hom.set (a', a)) (ι ` D.cones a') (Φ.FUN a'))"
using 1 2 by auto
show "⋀x. x ∈ Hom.set (a', a) ⟹ Φ.FUN a' x = ?F x"
proof -
fix x
assume x: "x ∈ Hom.set (a', a)"
hence ψx: "«ψ (a', a) x : a' → a»"
using a' Ya.ide_a Hom.ψ_mapsto by auto
show "Φ.FUN a' x = ?F x"
proof -
have "Φ.FUN a' x = Cones.FUN (ψ (a', a) x) (ι χ)"
using a' x Φ_FUN_simp by simp
also have "... = restrict (ι o D.cones_map (ψ (a', a) x) o 𝗈) (ι ` D.cones a) (ι χ)"
using ψx Cones.map_simp Cones.preserves_arr [of "ψ (a', a) x"] S.Fun_mkArr
by (elim C.in_homE, auto)
also have "... = ?F x" using cone_χ by simp
ultimately show ?thesis by simp
qed
qed
qed
finally show "Φ a' = S.mkArr (Hom.set (a', a)) (ι ` D.cones a') ?F" by auto
qed
qed
end
sublocale representation_of_cones_functor ⊆ limit_situation J C D S φ ι a Φ χ
using induces_limit_situation by auto
section "Categories with Limits"
context category
begin
text‹
A category @{term[source=true] C} has limits of shape @{term J} if every diagram of shape
@{term J} admits a limit cone.
›
definition has_limits_of_shape
where "has_limits_of_shape J ≡ ∀D. diagram J C D ⟶ (∃a χ. limit_cone J C D a χ)"
text‹
A category has limits at a type @{typ 'j} if it has limits of shape @{term J}
for every category @{term J} whose arrows are of type @{typ 'j}.
›
definition has_limits
where "has_limits (_ :: 'j) ≡ ∀J :: 'j comp. category J ⟶ has_limits_of_shape J"
text‹
Whether a category has limits of shape ‹J› truly depends only on the ``shape''
(\emph{i.e.}~isomorphism class) of ‹J› and not on details of its construction.
›
lemma has_limits_preserved_by_isomorphism:
assumes "has_limits_of_shape J" and "isomorphic_categories J J'"
shows "has_limits_of_shape J'"
proof -
interpret J: category J
using assms(2) isomorphic_categories_def isomorphic_categories_axioms_def by auto
interpret J': category J'
using assms(2) isomorphic_categories_def isomorphic_categories_axioms_def by auto
from assms(2) obtain φ ψ where IF: "inverse_functors J' J φ ψ"
using isomorphic_categories_def isomorphic_categories_axioms_def
inverse_functors_sym
by blast
interpret IF: inverse_functors J' J φ ψ using IF by auto
have ψφ: "ψ o φ = J.map" using IF.inv by metis
have φψ: "φ o ψ = J'.map" using IF.inv' by metis
have "⋀D'. diagram J' C D' ⟹ ∃a χ. limit_cone J' C D' a χ"
proof -
fix D'
assume D': "diagram J' C D'"
interpret D': diagram J' C D' using D' by auto
interpret D: composite_functor J J' C φ D' ..
interpret D: diagram J C ‹D' o φ› ..
have D: "diagram J C (D' o φ)" ..
from assms(1) obtain a χ where χ: "D.limit_cone a χ"
using D has_limits_of_shape_def by blast
interpret χ: limit_cone J C ‹D' o φ› a χ using χ by auto
interpret A': constant_functor J' C a
using χ.ide_apex by (unfold_locales, auto)
have χoψ: "cone J' C (D' o φ o ψ) a (χ o ψ)"
using comp_cone_functor IF.G.functor_axioms χ.cone_axioms by fastforce
hence χoψ: "cone J' C D' a (χ o ψ)"
using φψ by (metis D'.functor_axioms Fun.comp_assoc comp_functor_identity)
interpret χoψ: cone J' C D' a ‹χ o ψ› using χoψ by auto
interpret χoψ: limit_cone J' C D' a ‹χ o ψ›
proof
fix a' χ'
assume χ': "D'.cone a' χ'"
interpret χ': cone J' C D' a' χ' using χ' by auto
have χ'oφ: "cone J C (D' o φ) a' (χ' o φ)"
using χ' comp_cone_functor IF.F.functor_axioms by fastforce
interpret χ'oφ: cone J C ‹D' o φ› a' ‹χ' o φ› using χ'oφ by auto
have "cone J C (D' o φ) a' (χ' o φ)" ..
hence 1: "∃!f. «f : a' → a» ∧ D.cones_map f χ = χ' o φ"
using χ.is_universal by simp
show "∃!f. «f : a' → a» ∧ D'.cones_map f (χ o ψ) = χ'"
proof
let ?f = "THE f. «f : a' → a» ∧ D.cones_map f χ = χ' o φ"
have f: "«?f : a' → a» ∧ D.cones_map ?f χ = χ' o φ"
using 1 theI' [of "λf. «f : a' → a» ∧ D.cones_map f χ = χ' o φ"] by blast
have f_in_hom: "«?f : a' → a»" using f by blast
have "D'.cones_map ?f (χ o ψ) = χ'"
proof
fix j'
have "¬J'.arr j' ⟹ D'.cones_map ?f (χ o ψ) j' = χ' j'"
proof -
assume j': "¬J'.arr j'"
have "D'.cones_map ?f (χ o ψ) j' = null"
using j' f_in_hom χoψ by fastforce
thus ?thesis
using j' χ'.is_extensional by simp
qed
moreover have "J'.arr j' ⟹ D'.cones_map ?f (χ o ψ) j' = χ' j'"
proof -
assume j': "J'.arr j'"
have "D'.cones_map ?f (χ o ψ) j' = χ (ψ j') ⋅ ?f"
using j' f χoψ by fastforce
also have "... = D.cones_map ?f χ (ψ j')"
using j' f_in_hom χ χ.cone_χ by fastforce
also have "... = χ' j'"
using j' f χ φψ Fun.comp_def J'.map_simp by metis
finally show "D'.cones_map ?f (χ o ψ) j' = χ' j'" by auto
qed
ultimately show "D'.cones_map ?f (χ o ψ) j' = χ' j'" by blast
qed
thus "«?f : a' → a» ∧ D'.cones_map ?f (χ o ψ) = χ'" using f by auto
fix f'
assume f': "«f' : a' → a» ∧ D'.cones_map f' (χ o ψ) = χ'"
have "D.cones_map f' χ = χ' o φ"
proof
fix j
have "¬J.arr j ⟹ D.cones_map f' χ j = (χ' o φ) j"
using f' χ χ'oφ.is_extensional χ.cone_χ mem_Collect_eq restrict_apply by auto
moreover have "J.arr j ⟹ D.cones_map f' χ j = (χ' o φ) j"
proof -
assume j: "J.arr j"
have "D.cones_map f' χ j = C (χ j) f'"
using j f' χ.cone_χ by auto
also have "... = C ((χ o ψ) (φ j)) f'"
using j f' ψφ by (metis comp_apply J.map_simp)
also have "... = D'.cones_map f' (χ o ψ) (φ j)"
using j f' χoψ by fastforce
also have "... = (χ' o φ) j"
using j f' by auto
finally show "D.cones_map f' χ j = (χ' o φ) j" by auto
qed
ultimately show "D.cones_map f' χ j = (χ' o φ) j" by blast
qed
hence "«f' : a' → a» ∧ D.cones_map f' χ = χ' o φ"
using f' by auto
moreover have "⋀P x x'. (∃!x. P x) ∧ P x ∧ P x' ⟹ x = x'"
by auto
ultimately show "f' = ?f" using 1 f by blast
qed
qed
have "limit_cone J' C D' a (χ o ψ)" ..
thus "∃a χ. limit_cone J' C D' a χ" by blast
qed
thus ?thesis using has_limits_of_shape_def by auto
qed
end
subsection "Diagonal Functors"
text‹
The existence of limits can also be expressed in terms of adjunctions: a category @{term C}
has limits of shape @{term J} if the diagonal functor taking each object @{term a}
in @{term C} to the constant-@{term a} diagram and each arrow ‹f ∈ C.hom a a'›
to the constant-@{term f} natural transformation between diagrams is a left adjoint functor.
›
locale diagonal_functor =
C: category C +
J: category J +
J_C: functor_category J C
for J :: "'j comp" (infixr "⋅⇩J" 55)
and C :: "'c comp" (infixr "⋅" 55)
begin
notation J.in_hom ("«_ : _ →⇩J _»")
notation J_C.comp (infixr "⋅⇩[⇩J⇩,⇩C⇩]" 55)
notation J_C.in_hom ("«_ : _ →⇩[⇩J⇩,⇩C⇩] _»")
definition map :: "'c ⇒ ('j, 'c) J_C.arr"
where "map f = (if C.arr f then J_C.MkArr (constant_functor.map J C (C.dom f))
(constant_functor.map J C (C.cod f))
(constant_transformation.map J C f)
else J_C.null)"
lemma is_functor:
shows "functor C J_C.comp map"
proof
fix f
show "¬ C.arr f ⟹ local.map f = J_C.null"
using map_def by simp
assume f: "C.arr f"
interpret Dom_f: constant_functor J C ‹C.dom f›
using f by (unfold_locales, auto)
interpret Cod_f: constant_functor J C ‹C.cod f›
using f by (unfold_locales, auto)
interpret Fun_f: constant_transformation J C f
using f by (unfold_locales, auto)
show 1: "J_C.arr (map f)"
using f map_def by (simp add: Fun_f.natural_transformation_axioms)
show "J_C.dom (map f) = map (C.dom f)"
proof -
have "constant_transformation J C (C.dom f)"
apply unfold_locales using f by auto
hence "constant_transformation.map J C (C.dom f) = Dom_f.map"
using Dom_f.map_def constant_transformation.map_def [of J C "C.dom f"] by auto
thus ?thesis using f 1 by (simp add: map_def J_C.dom_char)
qed
show "J_C.cod (map f) = map (C.cod f)"
proof -
have "constant_transformation J C (C.cod f)"
apply unfold_locales using f by auto
hence "constant_transformation.map J C (C.cod f) = Cod_f.map"
using Cod_f.map_def constant_transformation.map_def [of J C "C.cod f"] by auto
thus ?thesis using f 1 by (simp add: map_def J_C.cod_char)
qed
next
fix f g
assume g: "C.seq g f"
have f: "C.arr f" using g by auto
interpret Dom_f: constant_functor J C ‹C.dom f›
using f by (unfold_locales, auto)
interpret Cod_f: constant_functor J C ‹C.cod f›
using f by (unfold_locales, auto)
interpret Fun_f: constant_transformation J C f
using f by (unfold_locales, auto)
interpret Cod_g: constant_functor J C ‹C.cod g›
using g by (unfold_locales, auto)
interpret Fun_g: constant_transformation J C g
using g by (unfold_locales, auto)
interpret Fun_g: natural_transformation J C Cod_f.map Cod_g.map Fun_g.map
apply unfold_locales
using f g C.seqE [of g f] C.comp_arr_dom C.comp_cod_arr Fun_g.is_extensional by auto
interpret Fun_fg: vertical_composite
J C Dom_f.map Cod_f.map Cod_g.map Fun_f.map Fun_g.map ..
have 1: "J_C.arr (map f)"
using f map_def by (simp add: Fun_f.natural_transformation_axioms)
show "map (g ⋅ f) = map g ⋅⇩[⇩J⇩,⇩C⇩] map f"
proof -
have "map (C g f) = J_C.MkArr Dom_f.map Cod_g.map
(constant_transformation.map J C (C g f))"
using f g map_def by simp
also have "... = J_C.MkArr Dom_f.map Cod_g.map (λj. if J.arr j then C g f else C.null)"
proof -
have "constant_transformation J C (g ⋅ f)"
apply unfold_locales using g by auto
thus ?thesis using constant_transformation.map_def by metis
qed
also have "... = J_C.comp (J_C.MkArr Cod_f.map Cod_g.map Fun_g.map)
(J_C.MkArr Dom_f.map Cod_f.map Fun_f.map)"
proof -
have "J_C.MkArr Cod_f.map Cod_g.map Fun_g.map ⋅⇩[⇩J⇩,⇩C⇩]
J_C.MkArr Dom_f.map Cod_f.map Fun_f.map
= J_C.MkArr Dom_f.map Cod_g.map Fun_fg.map"
using J_C.comp_char J_C.comp_MkArr Fun_f.natural_transformation_axioms
Fun_g.natural_transformation_axioms
by blast
also have "... = J_C.MkArr Dom_f.map Cod_g.map
(λj. if J.arr j then g ⋅ f else C.null)"
proof -
have "Fun_fg.map = (λj. if J.arr j then g ⋅ f else C.null)"
using 1 f g Fun_fg.map_def by auto
thus ?thesis by auto
qed
finally show ?thesis by auto
qed
also have "... = map g ⋅⇩[⇩J⇩,⇩C⇩] map f"
using f g map_def by fastforce
finally show ?thesis by auto
qed
qed
sublocale "functor" C J_C.comp map
using is_functor by auto
text‹
The objects of ‹[J, C]› correspond bijectively to diagrams of shape @{term J}
in @{term C}.
›
lemma ide_determines_diagram:
assumes "J_C.ide d"
shows "diagram J C (J_C.Map d)" and "J_C.MkIde (J_C.Map d) = d"
proof -
interpret δ: natural_transformation J C ‹J_C.Map d› ‹J_C.Map d› ‹J_C.Map d›
using assms J_C.ide_char J_C.arr_MkArr by fastforce
interpret D: "functor" J C ‹J_C.Map d› ..
show "diagram J C (J_C.Map d)" ..
show "J_C.MkIde (J_C.Map d) = d"
using assms J_C.ide_char by (metis J_C.ideD(1) J_C.MkArr_Map)
qed
lemma diagram_determines_ide:
assumes "diagram J C D"
shows "J_C.ide (J_C.MkIde D)" and "J_C.Map (J_C.MkIde D) = D"
proof -
interpret D: diagram J C D using assms by auto
show "J_C.ide (J_C.MkIde D)" using J_C.ide_char
using D.functor_axioms J_C.ide_MkIde by auto
thus "J_C.Map (J_C.MkIde D) = D"
using J_C.in_homE by simp
qed
lemma bij_betw_ide_diagram:
shows "bij_betw J_C.Map (Collect J_C.ide) (Collect (diagram J C))"
proof (intro bij_betwI)
show "J_C.Map ∈ Collect J_C.ide → Collect (diagram J C)"
using ide_determines_diagram by blast
show "J_C.MkIde ∈ Collect (diagram J C) → Collect J_C.ide"
using diagram_determines_ide by blast
show "⋀d. d ∈ Collect J_C.ide ⟹ J_C.MkIde (J_C.Map d) = d"
using ide_determines_diagram by blast
show "⋀D. D ∈ Collect (diagram J C) ⟹ J_C.Map (J_C.MkIde D) = D"
using diagram_determines_ide by blast
qed
text‹
Arrows from from the diagonal functor correspond bijectively to cones.
›
lemma arrow_determines_cone:
assumes "J_C.ide d" and "arrow_from_functor C J_C.comp map a d x"
shows "cone J C (J_C.Map d) a (J_C.Map x)"
and "J_C.MkArr (constant_functor.map J C a) (J_C.Map d) (J_C.Map x) = x"
proof -
interpret D: diagram J C ‹J_C.Map d›
using assms ide_determines_diagram by auto
interpret x: arrow_from_functor C J_C.comp map a d x
using assms by auto
interpret A: constant_functor J C a
using x.arrow by (unfold_locales, auto)
interpret α: constant_transformation J C a
using x.arrow by (unfold_locales, auto)
have Dom_x: "J_C.Dom x = A.map"
proof -
have "J_C.dom x = map a" using x.arrow by blast
hence "J_C.Map (J_C.dom x) = J_C.Map (map a)" by simp
hence "J_C.Dom x = J_C.Map (map a)"
using A.value_is_ide x.arrow J_C.in_homE by (metis J_C.Map_dom)
moreover have "J_C.Map (map a) = α.map"
using A.value_is_ide preserves_ide map_def by simp
ultimately show ?thesis using α.map_def A.map_def by auto
qed
have Cod_x: "J_C.Cod x = J_C.Map d"
using x.arrow by auto
interpret χ: natural_transformation J C A.map ‹J_C.Map d› ‹J_C.Map x›
using x.arrow J_C.arr_char [of x] Dom_x Cod_x by force
show "D.cone a (J_C.Map x)" ..
show "J_C.MkArr A.map (J_C.Map d) (J_C.Map x) = x"
using x.arrow Dom_x Cod_x χ.natural_transformation_axioms
by (intro J_C.arr_eqI, auto)
qed
lemma cone_determines_arrow:
assumes "J_C.ide d" and "cone J C (J_C.Map d) a χ"
shows "arrow_from_functor C J_C.comp map a d
(J_C.MkArr (constant_functor.map J C a) (J_C.Map d) χ)"
and "J_C.Map (J_C.MkArr (constant_functor.map J C a) (J_C.Map d) χ) = χ"
proof -
interpret χ: cone J C ‹J_C.Map d› a χ using assms(2) by auto
let ?x = "J_C.MkArr χ.A.map (J_C.Map d) χ"
interpret x: arrow_from_functor C J_C.comp map a d ?x
proof
have "«J_C.MkArr χ.A.map (J_C.Map d) χ :
J_C.MkIde χ.A.map →⇩[⇩J⇩,⇩C⇩] J_C.MkIde (J_C.Map d)»"
using χ.natural_transformation_axioms by auto
moreover have "J_C.MkIde χ.A.map = map a"
using χ.A.value_is_ide map_def χ.A.map_def C.ide_char
by (metis (no_types, lifting) J_C.dom_MkArr preserves_arr preserves_dom)
moreover have "J_C.MkIde (J_C.Map d) = d"
using assms ide_determines_diagram(2) by simp
ultimately show "C.ide a ∧ «J_C.MkArr χ.A.map (J_C.Map d) χ : map a →⇩[⇩J⇩,⇩C⇩] d»"
using χ.A.value_is_ide by simp
qed
show "arrow_from_functor C J_C.comp map a d ?x" ..
show "J_C.Map (J_C.MkArr (constant_functor.map J C a) (J_C.Map d) χ) = χ"
by (simp add: χ.natural_transformation_axioms)
qed
text‹
Transforming a cone by composing at the apex with an arrow @{term g} corresponds,
via the preceding bijections, to composition in ‹[J, C]› with the image of @{term g}
under the diagonal functor.
›
lemma cones_map_is_composition:
assumes "«g : a' → a»" and "cone J C D a χ"
shows "J_C.MkArr (constant_functor.map J C a') D (diagram.cones_map J C D g χ)
= J_C.MkArr (constant_functor.map J C a) D χ ⋅⇩[⇩J⇩,⇩C⇩] map g"
proof -
interpret A: constant_transformation J C a
using assms(1) by (unfold_locales, auto)
interpret χ: cone J C D a χ using assms(2) by auto
have cone_χ: "cone J C D a χ" ..
interpret A': constant_transformation J C a'
using assms(1) by (unfold_locales, auto)
let ?χ' = "χ.D.cones_map g χ"
interpret χ': cone J C D a' ?χ'
using assms(1) cone_χ χ.D.cones_map_mapsto by blast
let ?x = "J_C.MkArr χ.A.map D χ"
let ?x' = "J_C.MkArr χ'.A.map D ?χ'"
show "?x' = J_C.comp ?x (map g)"
proof (intro J_C.arr_eqI)
have x: "J_C.arr ?x"
using χ.natural_transformation_axioms J_C.arr_char [of ?x] by simp
show x': "J_C.arr ?x'"
using χ'.natural_transformation_axioms J_C.arr_char [of ?x'] by simp
have 3: "«?x : map a →⇩[⇩J⇩,⇩C⇩] J_C.MkIde D»"
proof -
have 1: "map a = J_C.MkIde A.map"
using χ.ide_apex A.equals_dom_if_value_is_ide A.equals_cod_if_value_is_ide map_def
by auto
have "J_C.arr ?x" using x by blast
moreover have "J_C.dom ?x = map a"
using x J_C.dom_char 1 x χ.ide_apex A.equals_dom_if_value_is_ide χ.D.functor_axioms
J_C.ide_char
by auto
moreover have "J_C.cod ?x = J_C.MkIde D" using x J_C.cod_char by auto
ultimately show ?thesis by fast
qed
have 4: "«?x' : map a' →⇩[⇩J⇩,⇩C⇩] J_C.MkIde D»"
proof -
have 1: "map a' = J_C.MkIde A'.map"
using χ'.ide_apex A'.equals_dom_if_value_is_ide A'.equals_cod_if_value_is_ide map_def
by auto
have "J_C.arr ?x'" using x' by blast
moreover have "J_C.dom ?x' = map a'"
using x' J_C.dom_char 1 x' χ'.ide_apex A'.equals_dom_if_value_is_ide χ.D.functor_axioms
J_C.ide_char
by force
moreover have "J_C.cod ?x' = J_C.MkIde D" using x' J_C.cod_char by auto
ultimately show ?thesis by fast
qed
have seq_xg: "J_C.seq ?x (map g)"
using assms(1) 3 preserves_hom [of g] by (intro J_C.seqI', auto)
show 2: "J_C.seq ?x (map g)"
using seq_xg J_C.seqI' by blast
show "J_C.Dom ?x' = J_C.Dom (?x ⋅⇩[⇩J⇩,⇩C⇩] map g)"
proof -
have "J_C.Dom ?x' = J_C.Dom (J_C.dom ?x')"
using x' J_C.Dom_dom by simp
also have "... = J_C.Dom (map a')"
using 4 by force
also have "... = J_C.Dom (J_C.dom (?x ⋅⇩[⇩J⇩,⇩C⇩] map g))"
using assms(1) 2 by auto
also have "... = J_C.Dom (?x ⋅⇩[⇩J⇩,⇩C⇩] map g)"
using seq_xg J_C.Dom_dom J_C.seqI' by blast
finally show ?thesis by auto
qed
show "J_C.Cod ?x' = J_C.Cod (?x ⋅⇩[⇩J⇩,⇩C⇩] map g)"
proof -
have "J_C.Cod ?x' = J_C.Cod (J_C.cod ?x')"
using x' J_C.Cod_cod by simp
also have "... = J_C.Cod (J_C.MkIde D)"
using 4 by force
also have "... = J_C.Cod (J_C.cod (?x ⋅⇩[⇩J⇩,⇩C⇩] map g))"
using 2 3 J_C.cod_comp J_C.in_homE by metis
also have "... = J_C.Cod (?x ⋅⇩[⇩J⇩,⇩C⇩] map g)"
using seq_xg J_C.Cod_cod J_C.seqI' by blast
finally show ?thesis by auto
qed
show "J_C.Map ?x' = J_C.Map (?x ⋅⇩[⇩J⇩,⇩C⇩] map g)"
proof -
interpret g: constant_transformation J C g
apply unfold_locales using assms(1) by auto
interpret χog: vertical_composite J C A'.map χ.A.map D g.map χ
using assms(1) C.comp_arr_dom C.comp_cod_arr A'.is_extensional g.is_extensional
apply (unfold_locales, auto)
by (elim J.seqE, auto)
have "J_C.Map (?x ⋅⇩[⇩J⇩,⇩C⇩] map g) = χog.map"
using assms(1) 2 J_C.comp_char map_def by auto
also have "... = J_C.Map ?x'"
using x' χog.map_def J_C.arr_char [of ?x'] natural_transformation.is_extensional
assms(1) cone_χ χog.map_simp_2
by fastforce
finally show ?thesis by auto
qed
qed
qed
text‹
Coextension along an arrow from a functor is equivalent to a transformation of cones.
›
lemma coextension_iff_cones_map:
assumes x: "arrow_from_functor C J_C.comp map a d x"
and g: "«g : a' → a»"
and x': "«x' : map a' →⇩[⇩J⇩,⇩C⇩] d»"
shows "arrow_from_functor.is_coext C J_C.comp map a x a' x' g
⟷ J_C.Map x' = diagram.cones_map J C (J_C.Map d) g (J_C.Map x)"
proof -
interpret x: arrow_from_functor C J_C.comp map a d x
using assms by auto
interpret A': constant_functor J C a'
using assms(2) by (unfold_locales, auto)
have x': "arrow_from_functor C J_C.comp map a' d x'"
using A'.value_is_ide assms(3) by (unfold_locales, blast)
have d: "J_C.ide d" using J_C.ide_cod x.arrow by blast
let ?D = "J_C.Map d"
let ?χ = "J_C.Map x"
let ?χ' = "J_C.Map x'"
interpret D: diagram J C ?D
using ide_determines_diagram J_C.ide_cod x.arrow by blast
interpret χ: cone J C ?D a ?χ
using assms(1) d arrow_determines_cone by simp
interpret γ: constant_transformation J C g
using g χ.ide_apex by (unfold_locales, auto)
interpret χog: vertical_composite J C A'.map χ.A.map ?D γ.map ?χ
using g C.comp_arr_dom C.comp_cod_arr γ.is_extensional by (unfold_locales, auto)
show ?thesis
proof
assume 0: "x.is_coext a' x' g"
show "?χ' = D.cones_map g ?χ"
proof -
have 1: "x' = x ⋅⇩[⇩J⇩,⇩C⇩] map g"
using 0 x.is_coext_def by blast
hence "?χ' = J_C.Map x'"
using 0 x.is_coext_def by fast
moreover have "... = D.cones_map g ?χ"
proof -
have "J_C.MkArr A'.map (J_C.Map d) (D.cones_map g (J_C.Map x)) =
x ⋅⇩[⇩J⇩,⇩C⇩] map g"
using d g cones_map_is_composition arrow_determines_cone(2) χ.cone_axioms
x.arrow_from_functor_axioms
by auto
hence f1: "J_C.MkArr A'.map (J_C.Map d) (D.cones_map g (J_C.Map x)) = x'"
by (metis 1)
have "J_C.arr (J_C.MkArr A'.map (J_C.Map d) (D.cones_map g (J_C.Map x)))"
using 1 d g cones_map_is_composition preserves_arr arrow_determines_cone(2)
χ.cone_axioms x.arrow_from_functor_axioms assms(3)
by auto
thus ?thesis
using f1 by auto
qed
ultimately show ?thesis by blast
qed
next
assume X': "?χ' = D.cones_map g ?χ"
show "x.is_coext a' x' g"
proof -
have 4: "J_C.seq x (map g)"
using g x.arrow mem_Collect_eq preserves_arr preserves_cod
by (elim C.in_homE, auto)
hence 1: "x ⋅⇩[⇩J⇩,⇩C⇩] map g =
J_C.MkArr (J_C.Dom (map g)) (J_C.Cod x)
(vertical_composite.map J C (J_C.Map (map g)) ?χ)"
using J_C.comp_char [of x "map g"] by simp
have 2: "vertical_composite.map J C (J_C.Map (map g)) ?χ = χog.map"
by (simp add: map_def γ.value_is_arr γ.natural_transformation_axioms)
have 3: "... = D.cones_map g ?χ"
using g χog.map_simp_2 χ.cone_axioms χog.is_extensional by auto
have "J_C.MkArr A'.map ?D ?χ' = J_C.comp x (map g)"
proof -
have f1: "A'.map = J_C.Dom (map g)"
using γ.natural_transformation_axioms map_def g by auto
have "J_C.Map d = J_C.Cod x"
using x.arrow by auto
thus ?thesis using f1 X' 1 2 3 by argo
qed
moreover have "J_C.MkArr A'.map ?D ?χ' = x'"
using d x' arrow_determines_cone by blast
ultimately show ?thesis
using g x.is_coext_def by simp
qed
qed
qed
end
locale right_adjoint_to_diagonal_functor =
C: category C +
J: category J +
J_C: functor_category J C +
Δ: diagonal_functor J C +
"functor" J_C.comp C G +
Adj: meta_adjunction J_C.comp C Δ.map G φ ψ
for J :: "'j comp" (infixr "⋅⇩J" 55)
and C :: "'c comp" (infixr "⋅" 55)
and G :: "('j, 'c) functor_category.arr ⇒ 'c"
and φ :: "'c ⇒ ('j, 'c) functor_category.arr ⇒ 'c"
and ψ :: "('j, 'c) functor_category.arr ⇒ 'c ⇒ ('j, 'c) functor_category.arr" +
assumes adjoint: "adjoint_functors J_C.comp C Δ.map G"
begin
interpretation Adj: adjunction J_C.comp C replete_setcat.comp Adj.φC Adj.φD Δ.map G
φ ψ Adj.η Adj.ε Adj.Φ Adj.Ψ
using Adj.induces_adjunction by simp
text‹
A right adjoint @{term G} to a diagonal functor maps each object @{term d} of
‹[J, C]› (corresponding to a diagram @{term D} of shape @{term J} in @{term C}
to an object of @{term C}. This object is the limit object, and the component at @{term d}
of the counit of the adjunction determines the limit cone.
›
lemma gives_limit_cones:
assumes "diagram J C D"
shows "limit_cone J C D (G (J_C.MkIde D)) (J_C.Map (Adj.ε (J_C.MkIde D)))"
proof -
interpret D: diagram J C D using assms by auto
let ?d = "J_C.MkIde D"
let ?a = "G ?d"
let ?x = "Adj.ε ?d"
let ?χ = "J_C.Map ?x"
have "diagram J C D" ..
hence 1: "J_C.ide ?d" using Δ.diagram_determines_ide by auto
hence 2: "J_C.Map (J_C.MkIde D) = D"
using assms 1 J_C.in_homE Δ.diagram_determines_ide(2) by simp
interpret x: terminal_arrow_from_functor C J_C.comp Δ.map ?a ?d ?x
apply unfold_locales
apply (metis (no_types, lifting) "1" preserves_ide Adj.ε_in_terms_of_ψ
Adj.εo_def Adj.εo_in_hom)
by (metis 1 Adj.has_terminal_arrows_from_functor(1)
terminal_arrow_from_functor.is_terminal)
have 3: "arrow_from_functor C J_C.comp Δ.map ?a ?d ?x" ..
interpret χ: cone J C D ?a ?χ
using 1 2 3 Δ.arrow_determines_cone [of ?d] by auto
have cone_χ: "D.cone ?a ?χ" ..
interpret χ: limit_cone J C D ?a ?χ
proof
fix a' χ'
assume cone_χ': "D.cone a' χ'"
interpret χ': cone J C D a' χ' using cone_χ' by auto
let ?x' = "J_C.MkArr χ'.A.map D χ'"
interpret x': arrow_from_functor C J_C.comp Δ.map a' ?d ?x'
using 1 2 by (metis Δ.cone_determines_arrow(1) cone_χ')
have "arrow_from_functor C J_C.comp Δ.map a' ?d ?x'" ..
hence 4: "∃!g. x.is_coext a' ?x' g"
using x.is_terminal by simp
have 5: "⋀g. «g : a' →⇩C ?a» ⟹ x.is_coext a' ?x' g ⟷ D.cones_map g ?χ = χ'"
proof -
fix g
assume g: "«g : a' →⇩C ?a»"
show "x.is_coext a' ?x' g ⟷ D.cones_map g ?χ = χ'"
proof -
have "«?x' : Δ.map a' →⇩[⇩J⇩,⇩C⇩] ?d»"
using x'.arrow by simp
thus ?thesis
using 1 2 3 g Δ.coextension_iff_cones_map Δ.cone_determines_arrow(2)
cone_χ'
by force
qed
qed
have 6: "⋀g. x.is_coext a' ?x' g ⟹ «g : a' →⇩C ?a»"
using x.is_coext_def by simp
show "∃!g. «g : a' →⇩C ?a» ∧ D.cones_map g ?χ = χ'"
proof -
have "∃g. «g : a' →⇩C ?a» ∧ D.cones_map g ?χ = χ'"
using 4 5 6 by meson
thus ?thesis
using 4 5 6 by blast
qed
qed
show "D.limit_cone ?a ?χ" ..
qed
corollary gives_limits:
assumes "diagram J C D"
shows "diagram.has_as_limit J C D (G (J_C.MkIde D))"
using assms gives_limit_cones by fastforce
end
lemma (in category) has_limits_iff_left_adjoint_diagonal:
assumes "category J"
shows "has_limits_of_shape J ⟷
left_adjoint_functor C (functor_category.comp J C) (diagonal_functor.map J C)"
proof -
interpret J: category J using assms by auto
interpret J_C: functor_category J C ..
interpret Δ: diagonal_functor J C ..
show ?thesis
proof
assume A: "left_adjoint_functor C J_C.comp Δ.map"
interpret Δ: left_adjoint_functor C J_C.comp Δ.map using A by auto
interpret Adj: meta_adjunction J_C.comp C Δ.map Δ.G Δ.φ Δ.ψ
using Δ.induces_meta_adjunction by auto
have "meta_adjunction J_C.comp C Δ.map Δ.G Δ.φ Δ.ψ" ..
hence 1: "adjoint_functors J_C.comp C Δ.map Δ.G"
using adjoint_functors_def by blast
interpret G: right_adjoint_to_diagonal_functor J C Δ.G Δ.φ Δ.ψ
using 1 by (unfold_locales, auto)
have "⋀D. diagram J C D ⟹ ∃a. diagram.has_as_limit J C D a"
using A G.gives_limits by blast
hence "⋀D. diagram J C D ⟹ ∃a χ. limit_cone J C D a χ"
by metis
thus "has_limits_of_shape J" using has_limits_of_shape_def by blast
next
text‹
If @{term "has_limits J"}, then every diagram @{term D} from @{term J} to
@{term[source=true] C} has a limit cone.
This means that, for every object @{term d} of the functor category
‹[J, C]›, there exists an object @{term a} of @{term C} and a terminal arrow from
‹Δ a› to @{term d} in ‹[J, C]›. The terminal arrow is given by the
limit cone.
›
assume A: "has_limits_of_shape J"
show "left_adjoint_functor C J_C.comp Δ.map"
proof
fix d
assume D: "J_C.ide d"
interpret D: diagram J C ‹J_C.Map d›
using D Δ.ide_determines_diagram by auto
let ?D = "J_C.Map d"
have "diagram J C (J_C.Map d)" ..
from this obtain a χ where limit: "limit_cone J C ?D a χ"
using A has_limits_of_shape_def by blast
interpret A: constant_functor J C a
using limit by (simp add: Limit.cone_def limit_cone_def)
interpret χ: limit_cone J C ?D a χ using limit by simp
have cone_χ: "cone J C ?D a χ" ..
let ?x = "J_C.MkArr A.map ?D χ"
interpret x: arrow_from_functor C J_C.comp Δ.map a d ?x
using D cone_χ Δ.cone_determines_arrow by auto
have "terminal_arrow_from_functor C J_C.comp Δ.map a d ?x"
proof
show "⋀a' x'. arrow_from_functor C J_C.comp Δ.map a' d x' ⟹ ∃!g. x.is_coext a' x' g"
proof -
fix a' x'
assume x': "arrow_from_functor C J_C.comp Δ.map a' d x'"
interpret x': arrow_from_functor C J_C.comp Δ.map a' d x' using x' by auto
interpret A': constant_functor J C a'
by (unfold_locales, simp add: x'.arrow)
let ?χ' = "J_C.Map x'"
interpret χ': cone J C ?D a' ?χ'
using D x' Δ.arrow_determines_cone by auto
have cone_χ': "cone J C ?D a' ?χ'" ..
let ?g = "χ.induced_arrow a' ?χ'"
show "∃!g. x.is_coext a' x' g"
proof
show "x.is_coext a' x' ?g"
proof (unfold x.is_coext_def)
have 1: "«?g : a' → a» ∧ D.cones_map ?g χ = ?χ'"
using χ.induced_arrow_def χ.is_universal cone_χ'
theI' [of "λf. «f : a' → a» ∧ D.cones_map f χ = ?χ'"]
by presburger
hence 2: "x' = ?x ⋅⇩[⇩J⇩,⇩C⇩] Δ.map ?g"
proof -
have "x' = J_C.MkArr A'.map ?D ?χ'"
using D Δ.arrow_determines_cone(2) x'.arrow_from_functor_axioms by auto
thus ?thesis
using 1 cone_χ Δ.cones_map_is_composition [of ?g a' a ?D χ] by simp
qed
show "«?g : a' → a» ∧ x' = ?x ⋅⇩[⇩J⇩,⇩C⇩] Δ.map ?g"
using 1 2 by auto
qed
next
fix g
assume X: "x.is_coext a' x' g"
show "g = ?g"
proof -
have "«g : a' → a» ∧ D.cones_map g χ = ?χ'"
proof
show G: "«g : a' → a»" using X x.is_coext_def by blast
show "D.cones_map g χ = ?χ'"
proof -
have "?χ' = J_C.Map (?x ⋅⇩[⇩J⇩,⇩C⇩] Δ.map g)"
using X x.is_coext_def [of a' x' g] by fast
also have "... = D.cones_map g χ"
proof -
interpret map_g: constant_transformation J C g
using G by (unfold_locales, auto)
interpret χ': vertical_composite J C
map_g.F.map A.map ‹χ.Φ.Ya.Cop_S.Map d›
map_g.map χ
proof (intro_locales)
have "map_g.G.map = A.map"
using G by blast
thus "natural_transformation_axioms J (⋅) map_g.F.map A.map map_g.map"
using map_g.natural_transformation_axioms
by (simp add: natural_transformation_def)
qed
have "J_C.Map (?x ⋅⇩[⇩J⇩,⇩C⇩] Δ.map g) = vertical_composite.map J C map_g.map χ"
proof -
have "J_C.seq ?x (Δ.map g)"
using G x.arrow by auto
thus ?thesis
using G Δ.map_def J_C.Map_comp' [of ?x "Δ.map g"] by auto
qed
also have "... = D.cones_map g χ"
using G cone_χ χ'.map_def map_g.map_def χ.is_natural_2 χ'.map_simp_2
by auto
finally show ?thesis by blast
qed
finally show ?thesis by auto
qed
qed
thus ?thesis
using cone_χ' χ.is_universal χ.induced_arrow_def
theI_unique [of "λg. «g : a' → a» ∧ D.cones_map g χ = ?χ'" g]
by presburger
qed
qed
qed
qed
thus "∃a x. terminal_arrow_from_functor C J_C.comp Δ.map a d x" by auto
qed
qed
qed
section "Right Adjoint Functors Preserve Limits"
context right_adjoint_functor
begin
lemma preserves_limits:
fixes J :: "'j comp"
assumes "diagram J C E" and "diagram.has_as_limit J C E a"
shows "diagram.has_as_limit J D (G o E) (G a)"
proof -
text‹
From the assumption that @{term E} has a limit, obtain a limit cone @{term χ}.
›
interpret J: category J using assms(1) diagram_def by auto
interpret E: diagram J C E using assms(1) by auto
from assms(2) obtain χ where χ: "limit_cone J C E a χ" by auto
interpret χ: limit_cone J C E a χ using χ by auto
have a: "C.ide a" using χ.ide_apex by auto
text‹
Form the @{term E}-image ‹GE› of the diagram @{term E}.
›
interpret GE: composite_functor J C D E G ..
interpret GE: diagram J D GE.map ..
text‹Let ‹Gχ› be the @{term G}-image of the cone @{term χ},
and note that it is a cone over ‹GE›.›
let ?Gχ = "G o χ"
interpret Gχ: cone J D GE.map ‹G a› ?Gχ
using χ.cone_axioms preserves_cones by blast
text‹
Claim that ‹Gχ› is a limit cone for diagram ‹GE›.
›
interpret Gχ: limit_cone J D GE.map ‹G a› ?Gχ
proof
text ‹
Let @{term κ} be an arbitrary cone over ‹GE›.
›
fix b κ
assume κ: "GE.cone b κ"
interpret κ: cone J D GE.map b κ using κ by auto
interpret Fb: constant_functor J C ‹F b›
apply unfold_locales
by (meson F_is_functor κ.ide_apex functor.preserves_ide)
interpret Adj: meta_adjunction C D F G φ ψ
using induces_meta_adjunction by auto
interpret Adj: adjunction C D replete_setcat.comp
Adj.φC Adj.φD F G φ ψ Adj.η Adj.ε Adj.Φ Adj.Ψ
using Adj.induces_adjunction by simp
text‹
For each arrow @{term j} of @{term J}, let @{term "χ' j"} be defined to be
the adjunct of @{term "χ j"}. We claim that @{term χ'} is a cone over @{term E}.
›
let ?χ' = "λj. if J.arr j then Adj.ε (C.cod (E j)) ⋅⇩C F (κ j) else C.null"
have cone_χ': "E.cone (F b) ?χ'"
proof
show "⋀j. ¬J.arr j ⟹ ?χ' j = C.null" by simp
fix j
assume j: "J.arr j"
show "C.dom (?χ' j) = Fb.map (J.dom j)" using j ψ_in_hom by simp
show "C.cod (?χ' j) = E (J.cod j)" using j ψ_in_hom by simp
show "E j ⋅⇩C ?χ' (J.dom j) = ?χ' j"
proof -
have "E j ⋅⇩C ?χ' (J.dom j) = (E j ⋅⇩C Adj.ε (E (J.dom j))) ⋅⇩C F (κ (J.dom j))"
using j C.comp_assoc by simp
also have "... = Adj.ε (E (J.cod j)) ⋅⇩C F (κ j)"
proof -
have "(E j ⋅⇩C Adj.ε (E (J.dom j))) ⋅⇩C F (κ (J.dom j))
= (Adj.ε (C.cod (E j)) ⋅⇩C Adj.FG.map (E j)) ⋅⇩C F (κ (J.dom j))"
using j Adj.ε.naturality [of "E j"] by fastforce
also have "... = Adj.ε (C.cod (E j)) ⋅⇩C Adj.FG.map (E j) ⋅⇩C F (κ (J.dom j))"
using C.comp_assoc by simp
also have "... = Adj.ε (E (J.cod j)) ⋅⇩C F (κ j)"
proof -
have "Adj.FG.map (E j) ⋅⇩C F (κ (J.dom j)) = F (GE.map j ⋅⇩D κ (J.dom j))"
using j by simp
hence "Adj.FG.map (E j) ⋅⇩C F (κ (J.dom j)) = F (κ j)"
using j κ.is_natural_1 by metis
thus ?thesis using j by simp
qed
finally show ?thesis by auto
qed
also have "... = ?χ' j"
using j by simp
finally show ?thesis by auto
qed
show "?χ' (J.cod j) ⋅⇩C Fb.map j = ?χ' j"
proof -
have "?χ' (J.cod j) ⋅⇩C Fb.map j = Adj.ε (E (J.cod j)) ⋅⇩C F (κ (J.cod j))"
using j Fb.value_is_ide Adj.ε.preserves_hom C.comp_arr_dom [of "F (κ (J.cod j))"]
C.comp_assoc
by simp
also have "... = Adj.ε (E (J.cod j)) ⋅⇩C F (κ j)"
using j κ.is_natural_1 κ.is_natural_2 Adj.ε.naturality J.arr_cod_iff_arr
by (metis J.cod_cod κ.A.map_simp)
also have "... = ?χ' j" using j by simp
finally show ?thesis by auto
qed
qed
text‹
Using the universal property of the limit cone @{term χ}, obtain the unique arrow
@{term f} that transforms @{term χ} into @{term χ'}.
›
from this χ.is_universal [of "F b" ?χ'] obtain f
where f: "«f : F b →⇩C a» ∧ E.cones_map f χ = ?χ'"
by auto
text‹
Let @{term g} be the adjunct of @{term f}, and show that @{term g} transforms
@{term Gχ} into @{term κ}.
›
let ?g = "G f ⋅⇩D Adj.η b"
have 1: "«?g : b →⇩D G a»" using f κ.ide_apex by fastforce
moreover have "GE.cones_map ?g ?Gχ = κ"
proof
fix j
have "¬J.arr j ⟹ GE.cones_map ?g ?Gχ j = κ j"
using 1 Gχ.cone_axioms κ.is_extensional by auto
moreover have "J.arr j ⟹ GE.cones_map ?g ?Gχ j = κ j"
proof -
fix j
assume j: "J.arr j"
have "GE.cones_map ?g ?Gχ j = G (χ j) ⋅⇩D ?g"
using j 1 Gχ.cone_axioms mem_Collect_eq restrict_apply by auto
also have "... = G (χ j ⋅⇩C f) ⋅⇩D Adj.η b"
using j f χ.preserves_hom [of j "J.dom j" "J.cod j"] D.comp_assoc by fastforce
also have "... = G (E.cones_map f χ j) ⋅⇩D Adj.η b"
proof -
have "χ j ⋅⇩C f = Adj.ε (C.cod (E j)) ⋅⇩C F (κ j)"
proof -
have "E.cone (C.cod f) χ"
using f χ.cone_axioms by blast
hence "χ j ⋅⇩C f = E.cones_map f χ j"
using χ.is_extensional by simp
also have "... = Adj.ε (C.cod (E j)) ⋅⇩C F (κ j)"
using j f by simp
finally show ?thesis by blast
qed
thus ?thesis
using f mem_Collect_eq restrict_apply Adj.F.is_extensional by simp
qed
also have "... = (G (Adj.ε (C.cod (E j))) ⋅⇩D Adj.η (D.cod (GE.map j))) ⋅⇩D κ j"
using j f Adj.η.naturality [of "κ j"] D.comp_assoc by auto
also have "... = D.cod (κ j) ⋅⇩D κ j"
using j Adj.ηε.triangle_G Adj.ε_in_terms_of_ψ Adj.εo_def
Adj.η_in_terms_of_φ Adj.ηo_def Adj.unit_counit_G
by fastforce
also have "... = κ j"
using j D.comp_cod_arr by simp
finally show "GE.cones_map ?g ?Gχ j = κ j" by metis
qed
ultimately show "GE.cones_map ?g ?Gχ j = κ j" by auto
qed
ultimately have "«?g : b →⇩D G a» ∧ GE.cones_map ?g ?Gχ = κ" by auto
text‹
It remains to be shown that @{term g} is the unique such arrow.
Given any @{term g'} that transforms @{term Gχ} into @{term κ},
its adjunct transforms @{term χ} into @{term χ'}.
The adjunct of @{term g'} is therefore equal to @{term f},
which implies @{term g'} = @{term g}.
›
moreover have "⋀g'. «g' : b →⇩D G a» ∧ GE.cones_map g' ?Gχ = κ ⟹ g' = ?g"
proof -
fix g'
assume g': "«g' : b →⇩D G a» ∧ GE.cones_map g' ?Gχ = κ"
have 1: "«ψ a g' : F b →⇩C a»"
using g' a ψ_in_hom by simp
have 2: "E.cones_map (ψ a g') χ = ?χ'"
proof
fix j
have "¬J.arr j ⟹ E.cones_map (ψ a g') χ j = ?χ' j"
using 1 χ.cone_axioms by auto
moreover have "J.arr j ⟹ E.cones_map (ψ a g') χ j = ?χ' j"
proof -
fix j
assume j: "J.arr j"
have "E.cones_map (ψ a g') χ j = χ j ⋅⇩C ψ a g'"
using 1 χ.cone_axioms χ.is_extensional by auto
also have "... = (χ j ⋅⇩C Adj.ε a) ⋅⇩C F g'"
using j a g' Adj.ψ_in_terms_of_ε C.comp_assoc Adj.ε_def by auto
also have "... = (Adj.ε (C.cod (E j)) ⋅⇩C F (G (χ j))) ⋅⇩C F g'"
using j a g' Adj.ε.naturality [of "χ j"] by simp
also have "... = Adj.ε (C.cod (E j)) ⋅⇩C F (κ j)"
using j a g' Gχ.cone_axioms C.comp_assoc by auto
finally show "E.cones_map (ψ a g') χ j = ?χ' j" by (simp add: j)
qed
ultimately show "E.cones_map (ψ a g') χ j = ?χ' j" by auto
qed
have "ψ a g' = f"
proof -
have "∃!f. «f : F b →⇩C a» ∧ E.cones_map f χ = ?χ'"
using cone_χ' χ.is_universal by simp
moreover have "«ψ a g' : F b →⇩C a» ∧ E.cones_map (ψ a g') χ = ?χ'"
using 1 2 by simp
ultimately show ?thesis
using ex1E [of "λf. «f : F b →⇩C a» ∧ E.cones_map f χ = ?χ'" "ψ a g' = f"]
using 1 2 Adj.ε.is_extensional C.comp_null(2) C.ex_un_null χ.cone_axioms f
mem_Collect_eq restrict_apply
by blast
qed
hence "φ b (ψ a g') = φ b f" by auto
hence "g' = φ b f" using χ.ide_apex g' by (simp add: φ_ψ)
moreover have "?g = φ b f" using f Adj.φ_in_terms_of_η κ.ide_apex Adj.η_def by auto
ultimately show "g' = ?g" by argo
qed
ultimately show "∃!g. «g : b →⇩D G a» ∧ GE.cones_map g ?Gχ = κ" by blast
qed
have "GE.limit_cone (G a) ?Gχ" ..
thus ?thesis by auto
qed
end
section "Special Kinds of Limits"
subsection "Terminal Objects"
text‹
An object of a category @{term C} is a terminal object if and only if it is a limit of the
empty diagram in @{term C}.
›
locale empty_diagram =
diagram J C D
for J :: "'j comp" (infixr "⋅⇩J" 55)
and C :: "'c comp" (infixr "⋅" 55)
and D :: "'j ⇒ 'c" +
assumes is_empty: "¬J.arr j"
begin
lemma has_as_limit_iff_terminal:
shows "has_as_limit a ⟷ C.terminal a"
proof
assume a: "has_as_limit a"
show "C.terminal a"
proof
have "∃χ. limit_cone a χ" using a by auto
from this obtain χ where χ: "limit_cone a χ" by blast
interpret χ: limit_cone J C D a χ using χ by auto
have cone_χ: "cone a χ" ..
show "C.ide a" using χ.ide_apex by auto
have 1: "χ = (λj. C.null)" using is_empty χ.is_extensional by auto
show "⋀a'. C.ide a' ⟹ ∃!f. «f : a' → a»"
proof -
fix a'
assume a': "C.ide a'"
interpret A': constant_functor J C a'
apply unfold_locales using a' by auto
let ?χ' = "λj. C.null"
have cone_χ': "cone a' ?χ'"
using a' is_empty apply unfold_locales by auto
hence "∃!f. «f : a' → a» ∧ cones_map f χ = ?χ'"
using χ.is_universal by force
moreover have "⋀f. «f : a' → a» ⟹ cones_map f χ = ?χ'"
using 1 cone_χ by auto
ultimately show "∃!f. «f : a' → a»" by blast
qed
qed
next
assume a: "C.terminal a"
show "has_as_limit a"
proof -
let ?χ = "λj. C.null"
have "C.ide a" using a C.terminal_def by simp
interpret A: constant_functor J C a
apply unfold_locales using ‹C.ide a› by simp
interpret χ: cone J C D a ?χ
using ‹C.ide a› is_empty by (unfold_locales, auto)
have cone_χ: "cone a ?χ" ..
have 1: "⋀a' χ'. cone a' χ' ⟹ χ' = (λj. C.null)"
proof -
fix a' χ'
assume χ': "cone a' χ'"
interpret χ': cone J C D a' χ' using χ' by auto
show "χ' = (λj. C.null)"
using is_empty χ'.is_extensional by metis
qed
have "limit_cone a ?χ"
proof
fix a' χ'
assume χ': "cone a' χ'"
have 2: "χ' = (λj. C.null)" using 1 χ' by simp
interpret χ': cone J C D a' χ' using χ' by auto
have "∃!f. «f : a' → a»" using a C.terminal_def χ'.ide_apex by simp
moreover have "⋀f. «f : a' → a» ⟹ cones_map f ?χ = χ'"
using 1 2 cones_map_mapsto cone_χ χ'.cone_axioms mem_Collect_eq by blast
ultimately show "∃!f. «f : a' → a» ∧ cones_map f (λj. C.null) = χ'"
by blast
qed
thus ?thesis by auto
qed
qed
end
subsection "Products"
text‹
A \emph{product} in a category @{term C} is a limit of a discrete diagram in @{term C}.
›
locale discrete_diagram =
J: category J +
diagram J C D
for J :: "'j comp" (infixr "⋅⇩J" 55)
and C :: "'c comp" (infixr "⋅" 55)
and D :: "'j ⇒ 'c" +
assumes is_discrete: "J.arr = J.ide"
begin
abbreviation mkCone
where "mkCone F ≡ (λj. if J.arr j then F j else C.null)"
lemma cone_mkCone:
assumes "C.ide a" and "⋀j. J.arr j ⟹ «F j : a → D j»"
shows "cone a (mkCone F)"
proof -
interpret A: constant_functor J C a
apply unfold_locales using assms(1) by auto
show "cone a (mkCone F)"
using assms(2) is_discrete
apply unfold_locales
apply auto
apply (metis C.in_homE C.comp_cod_arr)
using C.comp_arr_ide by fastforce
qed
lemma mkCone_cone:
assumes "cone a π"
shows "mkCone π = π"
proof -
interpret π: cone J C D a π
using assms by auto
show "mkCone π = π" using π.is_extensional by auto
qed
end
text‹
The following locale defines a discrete diagram in a category @{term C},
given an index set @{term I} and a function @{term D} mapping @{term I}
to objects of @{term C}. Here we obtain the diagram shape @{term J}
using a discrete category construction that allows us to directly identify
the objects of @{term J} with the elements of @{term I}, however this construction
can only be applied in case the set @{term I} is not the universe of its
element type.
›
locale discrete_diagram_from_map =
J: discrete_category I null +
C: category C
for I :: "'i set"
and C :: "'c comp" (infixr "⋅" 55)
and D :: "'i ⇒ 'c"
and null :: 'i +
assumes maps_to_ide: "i ∈ I ⟹ C.ide (D i)"
begin
definition map
where "map j ≡ if J.arr j then D j else C.null"
end
sublocale discrete_diagram_from_map ⊆ discrete_diagram J.comp C map
using map_def maps_to_ide J.arr_char J.Null_not_in_Obj J.null_char
by (unfold_locales, auto)
locale product_cone =
J: category J +
C: category C +
D: discrete_diagram J C D +
limit_cone J C D a π
for J :: "'j comp" (infixr "⋅⇩J" 55)
and C :: "'c comp" (infixr "⋅" 55)
and D :: "'j ⇒ 'c"
and a :: 'c
and π :: "'j ⇒ 'c"
begin
lemma is_cone:
shows "D.cone a π" ..
text‹
The following versions of @{prop is_universal} and @{prop induced_arrowI}
from the ‹limit_cone› locale are specialized to the case in which the
underlying diagram is a product diagram.
›
lemma is_universal':
assumes "C.ide b" and "⋀j. J.arr j ⟹ «F j: b → D j»"
shows "∃!f. «f : b → a» ∧ (∀j. J.arr j ⟶ π j ⋅ f = F j)"
proof -
let ?χ = "D.mkCone F"
interpret B: constant_functor J C b
apply unfold_locales using assms(1) by auto
have cone_χ: "D.cone b ?χ"
using assms D.is_discrete
apply unfold_locales
apply auto
apply (meson C.comp_ide_arr C.ide_in_hom C.seqI' D.preserves_ide)
using C.comp_arr_dom by blast
interpret χ: cone J C D b ?χ using cone_χ by auto
have "∃!f. «f : b → a» ∧ D.cones_map f π = ?χ"
using cone_χ is_universal by force
moreover have
"⋀f. «f : b → a» ⟹ D.cones_map f π = ?χ ⟷ (∀j. J.arr j ⟶ π j ⋅ f = F j)"
proof -
fix f
assume f: "«f : b → a»"
show "D.cones_map f π = ?χ ⟷ (∀j. J.arr j ⟶ π j ⋅ f = F j)"
proof
assume 1: "D.cones_map f π = ?χ"
show "∀j. J.arr j ⟶ π j ⋅ f = F j"
proof -
have "⋀j. J.arr j ⟹ π j ⋅ f = F j"
proof -
fix j
assume j: "J.arr j"
have "π j ⋅ f = D.cones_map f π j"
using j f cone_axioms by force
also have "... = F j" using j 1 by simp
finally show "π j ⋅ f = F j" by auto
qed
thus ?thesis by auto
qed
next
assume 1: "∀j. J.arr j ⟶ π j ⋅ f = F j"
show "D.cones_map f π = ?χ"
using 1 f is_cone χ.is_extensional D.is_discrete is_cone cone_χ by auto
qed
qed
ultimately show ?thesis by blast
qed
abbreviation induced_arrow' :: "'c ⇒ ('j ⇒ 'c) ⇒ 'c"
where "induced_arrow' b F ≡ induced_arrow b (D.mkCone F)"
lemma induced_arrowI':
assumes "C.ide b" and "⋀j. J.arr j ⟹ «F j : b → D j»"
shows "⋀j. J.arr j ⟹ π j ⋅ induced_arrow' b F = F j"
proof -
interpret B: constant_functor J C b
apply unfold_locales using assms(1) by auto
interpret χ: cone J C D b ‹D.mkCone F›
using assms D.cone_mkCone by blast
have cone_χ: "D.cone b (D.mkCone F)" ..
hence 1: "D.cones_map (induced_arrow' b F) π = D.mkCone F"
using induced_arrowI by blast
fix j
assume j: "J.arr j"
have "π j ⋅ induced_arrow' b F = D.cones_map (induced_arrow' b F) π j"
using induced_arrowI(1) cone_χ is_cone is_extensional by force
also have "... = F j"
using j 1 by auto
finally show "π j ⋅ induced_arrow' b F = F j"
by auto
qed
end
context discrete_diagram
begin
lemma product_coneI:
assumes "limit_cone a π"
shows "product_cone J C D a π"
proof -
interpret L: limit_cone J C D a π
using assms by auto
show "product_cone J C D a π" ..
qed
end
context category
begin
definition has_as_product
where "has_as_product J D a ≡ (∃π. product_cone J C D a π)"
lemma product_is_ide:
assumes "has_as_product J D a"
shows "ide a"
proof -
obtain π where π: "product_cone J C D a π"
using assms has_as_product_def by blast
interpret π: product_cone J C D a π
using π by auto
show ?thesis using π.ide_apex by auto
qed
text‹
A category has @{term I}-indexed products for an @{typ 'i}-set @{term I}
if every @{term I}-indexed discrete diagram has a product.
In order to reap the benefits of being able to directly identify the elements
of a set I with the objects of discrete category it generates (thereby avoiding
the use of coercion maps), it is necessary to assume that @{term "I ≠ UNIV"}.
If we want to assert that a category has products indexed by the universe of
some type @{typ 'i}, we have to pass to a larger type, such as @{typ "'i option"}.
›
definition has_products
where "has_products (I :: 'i set) ≡
I ≠ UNIV ∧
(∀J D. discrete_diagram J C D ∧ Collect (partial_magma.arr J) = I
⟶ (∃a. has_as_product J D a))"
lemma ex_productE:
assumes "∃a. has_as_product J D a"
obtains a π where "product_cone J C D a π"
using assms has_as_product_def someI_ex [of "λa. has_as_product J D a"] by metis
lemma has_products_if_has_limits:
assumes "has_limits (undefined :: 'j)" and "I ≠ (UNIV :: 'j set)"
shows "has_products I"
proof (unfold has_products_def, intro conjI allI impI)
show "I ≠ UNIV" by fact
fix J D
assume D: "discrete_diagram J C D ∧ Collect (partial_magma.arr J) = I"
interpret D: discrete_diagram J C D
using D by simp
have 1: "∃a. D.has_as_limit a"
using assms D D.diagram_axioms D.J.category_axioms
by (simp add: has_limits_of_shape_def has_limits_def)
show "∃a. has_as_product J D a"
using 1 has_as_product_def D.product_coneI by blast
qed
lemma has_finite_products_if_has_finite_limits:
assumes "⋀J :: 'j comp. (finite (Collect (partial_magma.arr J))) ⟹ has_limits_of_shape J"
and "finite (I :: 'j set)" and "I ≠ UNIV"
shows "has_products I"
proof (unfold has_products_def, intro conjI allI impI)
show "I ≠ UNIV" by fact
fix J D
assume D: "discrete_diagram J C D ∧ Collect (partial_magma.arr J) = I"
interpret D: discrete_diagram J C D
using D by simp
have 1: "∃a. D.has_as_limit a"
using assms D has_limits_of_shape_def D.diagram_axioms by auto
show "∃a. has_as_product J D a"
using 1 has_as_product_def D.product_coneI by blast
qed
lemma has_products_preserved_by_bijection:
assumes "has_products I" and "bij_betw φ I I'" and "I' ≠ UNIV"
shows "has_products I'"
proof (unfold has_products_def, intro conjI allI impI)
show "I' ≠ UNIV" by fact
show "⋀J' D'. discrete_diagram J' C D' ∧ Collect (partial_magma.arr J') = I'
⟹ ∃a. has_as_product J' D' a"
proof -
fix J' D'
assume 1: "discrete_diagram J' C D' ∧ Collect (partial_magma.arr J') = I'"
interpret J': category J'
using 1 by (simp add: discrete_diagram_def)
interpret D': discrete_diagram J' C D'
using 1 by simp
interpret J: discrete_category I ‹SOME x. x ∉ I›
using assms has_products_def [of I] someI_ex [of "λx. x ∉ I"]
by unfold_locales auto
have 2: "Collect J.arr = I ∧ Collect J'.arr = I'"
using 1 by auto
have φ: "bij_betw φ (Collect J.arr) (Collect J'.arr)"
using 2 assms(2) by simp
let ?φ = "λj. if J.arr j then φ j else J'.null"
let ?φ' = "λj'. if J'.arr j' then the_inv_into I φ j' else J.null"
interpret φ: "functor" J.comp J' ?φ
proof -
have "φ ` I = I'"
using φ 2 bij_betw_def [of φ I I'] by simp
hence "⋀j. J.arr j ⟹ J'.arr (?φ j)"
using 1 D'.is_discrete by auto
thus "functor J.comp J' ?φ"
using D'.is_discrete J.is_discrete J.seqE
by unfold_locales auto
qed
interpret φ': "functor" J' J.comp ?φ'
proof -
have "the_inv_into I φ ` I' = I"
using assms(2) φ bij_betw_the_inv_into bij_betw_imp_surj_on by metis
hence "⋀j'. J'.arr j' ⟹ J.arr (?φ' j')"
using 2 D'.is_discrete J.is_discrete by auto
thus "functor J' J.comp ?φ'"
using D'.is_discrete J.is_discrete J'.seqE
by unfold_locales auto
qed
let ?D = "λi. D' (φ i)"
interpret D: discrete_diagram_from_map I C ?D ‹SOME j. j ∉ I›
using assms 1 D'.is_discrete bij_betw_imp_surj_on φ.preserves_ide
by unfold_locales auto
obtain a where a: "has_as_product J.comp D.map a"
using assms D.discrete_diagram_axioms has_products_def [of I] by auto
obtain π where π: "product_cone J.comp C D.map a π"
using a has_as_product_def by blast
interpret π: product_cone J.comp C D.map a π
using π by simp
let ?π' = "π o ?φ'"
interpret A: constant_functor J' C a
using π.ide_apex by unfold_locales simp
interpret π': natural_transformation J' C A.map D' ?π'
proof -
have "π.A.map ∘ ?φ' = A.map"
using φ A.map_def φ'.preserves_arr π.A.is_extensional J.not_arr_null by auto
moreover have "D.map ∘ ?φ' = D'"
proof
fix j'
have "J'.arr j' ⟹ (D.map ∘ ?φ') j' = D' j'"
proof -
assume 2: "J'.arr j'"
have 3: "inj_on φ I"
using assms(2) bij_betw_imp_inj_on by auto
have "φ ` I = I'"
by (metis (no_types) assms(2) bij_betw_imp_surj_on)
hence "φ ` I = Collect J'.arr"
using 1 by force
thus ?thesis
using 2 3 D.map_def φ'.preserves_arr f_the_inv_into_f by fastforce
qed
moreover have "¬ J'.arr j' ⟹ (D.map ∘ ?φ') j' = D' j'"
using D.is_extensional D'.is_extensional
by (simp add: J.Null_not_in_Obj J.null_char)
ultimately show "(D.map ∘ ?φ') j' = D' j'" by blast
qed
ultimately show "natural_transformation J' C A.map D' ?π'"
using π.natural_transformation_axioms φ'.natural_transformation_axioms
horizontal_composite [of J' J.comp ?φ' ?φ' ?φ' C π.A.map D.map π]
by simp
qed
interpret π': cone J' C D' a ?π' ..
interpret π': product_cone J' C D' a ?π'
proof
fix a' χ'
assume χ': "D'.cone a' χ'"
interpret χ': cone J' C D' a' χ'
using χ' by simp
show "∃!f. «f : a' → a» ∧ D'.cones_map f (π ∘ ?φ') = χ'"
proof -
let ?χ = "χ' o ?φ"
interpret A': constant_functor J.comp C a'
using χ'.ide_apex by unfold_locales simp
interpret χ: natural_transformation J.comp C A'.map D.map ?χ
proof -
have "χ'.A.map ∘ ?φ = A'.map"
using φ φ.preserves_arr A'.map_def χ'.A.is_extensional by auto
moreover have "D' ∘ ?φ = D.map"
using φ D.map_def D'.is_extensional by auto
ultimately show "natural_transformation J.comp C A'.map D.map ?χ"
using χ'.natural_transformation_axioms φ.natural_transformation_axioms
horizontal_composite [of J.comp J' ?φ ?φ ?φ C χ'.A.map D' χ']
by simp
qed
interpret χ: cone J.comp C D.map a' ?χ ..
have *: "∃!f. «f : a' → a» ∧ D.cones_map f π = ?χ"
using π.is_universal χ.cone_axioms by simp
show "∃!f. «f : a' → a» ∧ D'.cones_map f ?π' = χ'"
proof -
have "∃f. «f : a' → a» ∧ D'.cones_map f ?π' = χ'"
proof -
obtain f where f: "«f : a' → a» ∧ D.cones_map f π = ?χ"
using * by blast
have "D'.cones_map f ?π' = χ'"
proof
fix j'
show "D'.cones_map f ?π' j' = χ' j'"
proof (cases "J'.arr j'")
assume j': "¬ J'.arr j'"
show "D'.cones_map f ?π' j' = χ' j'"
using f j' χ'.is_extensional π'.cone_axioms by auto
next
assume j': "J'.arr j'"
show "D'.cones_map f ?π' j' = χ' j'"
proof -
have "D'.cones_map f ?π' j' = π (the_inv_into I φ j') ⋅ f"
using f j' π'.cone_axioms by auto
also have "... = D.cones_map f π (the_inv_into I φ j')"
proof -
have "arr f ∧ dom f = a' ∧ cod f = a"
using f by blast
thus ?thesis
using φ'.preserves_arr π.cone_χ j' by auto
qed
also have "... = (χ' ∘ ?φ) (the_inv_into I φ j')"
using f by simp
also have "... = χ' j'"
using assms(2) j' 2 bij_betw_def [of φ I I'] bij_betw_imp_inj_on
φ'.preserves_arr f_the_inv_into_f
by fastforce
finally show ?thesis by simp
qed
qed
qed
thus ?thesis using f by blast
qed
moreover have "⋀f f'. ⟦ «f : a' → a»; D'.cones_map f ?π' = χ';
«f' : a' → a»; D'.cones_map f' ?π' = χ' ⟧
⟹ f = f'"
proof -
fix f f'
assume f: "«f : a' → a»" and f': "«f' : a' → a»"
and fχ': "D'.cones_map f ?π' = χ'" and f'χ': "D'.cones_map f' ?π' = χ'"
have "D.cones_map f π = χ' ∘ ?φ ∧ D.cones_map f' π = χ' o ?φ"
proof (intro conjI)
show "D.cones_map f π = χ' ∘ ?φ"
proof
fix j
have "¬ J.arr j ⟹ D.cones_map f π j = (χ' ∘ ?φ) j"
using f fχ' π.cone_axioms χ.is_extensional by auto
moreover have "J.arr j ⟹ D.cones_map f π j = (χ' ∘ ?φ) j"
proof -
assume j: "J.arr j"
have 1: "j = the_inv_into I φ (φ j)"
using assms(2) j φ the_inv_into_f_f bij_betw_imp_inj_on J.arr_char
by metis
have "D.cones_map f π j = D.cones_map f π (the_inv_into I φ (φ j))"
using 1 by simp
also have "... = (χ' ∘ ?φ) j"
using f j fχ' 1 π.cone_axioms π'.cone_axioms φ.preserves_arr by auto
finally show "D.cones_map f π j = (χ' ∘ ?φ) j" by blast
qed
ultimately show "D.cones_map f π j = (χ' ∘ ?φ) j" by blast
qed
show "D.cones_map f' π = χ' ∘ ?φ"
proof
fix j
have "¬ J.arr j ⟹ D.cones_map f' π j = (χ' ∘ ?φ) j"
using f' fχ' π.cone_axioms χ.is_extensional by auto
moreover have "J.arr j ⟹ D.cones_map f' π j = (χ' ∘ ?φ) j"
proof -
assume j: "J.arr j"
have 1: "j = the_inv_into I φ (φ j)"
using assms(2) j φ the_inv_into_f_f bij_betw_imp_inj_on J.arr_char
by metis
have "D.cones_map f' π j = D.cones_map f' π (the_inv_into I φ (φ j))"
using 1 by simp
also have "... = (χ' ∘ ?φ) j"
using f' j f'χ' 1 π.cone_axioms π'.cone_axioms φ.preserves_arr by auto
finally show "D.cones_map f' π j = (χ' ∘ ?φ) j" by blast
qed
ultimately show "D.cones_map f' π j = (χ' ∘ ?φ) j" by blast
qed
qed
thus "f = f'"
using f f' * by auto
qed
ultimately show ?thesis by blast
qed
qed
qed
have "has_as_product J' D' a"
using has_as_product_def π'.product_cone_axioms by auto
thus "∃a. has_as_product J' D' a" by blast
qed
qed
lemma ide_is_unary_product:
assumes "ide a"
shows "⋀m n :: nat. m ≠ n ⟹ has_as_product (discrete_category.comp {m :: nat} (n :: nat))
(λi. if i = m then a else null) a"
proof -
fix m n :: nat
assume neq: "m ≠ n"
have "{m :: nat} ≠ UNIV"
proof -
have "finite {m :: nat}" by simp
moreover have "¬finite (UNIV :: nat set)" by simp
ultimately show ?thesis by fastforce
qed
interpret J: discrete_category "{m :: nat}" ‹n :: nat›
using neq ‹{m :: nat} ≠ UNIV› by unfold_locales auto
let ?D = "λi. if i = m then a else null"
interpret D: discrete_diagram J.comp C ?D
apply unfold_locales
using assms J.null_char neq
apply auto
by metis
interpret A: constant_functor J.comp C a
using assms by unfold_locales auto
show "has_as_product J.comp ?D a"
proof (unfold has_as_product_def)
let ?π = "λi :: nat. if i = m then a else null"
interpret π: natural_transformation J.comp C A.map ?D ?π
using assms J.arr_char J.dom_char J.cod_char
by unfold_locales auto
interpret π: cone J.comp C ?D a ?π ..
interpret π: product_cone J.comp C ?D a ?π
proof
fix a' χ'
assume χ': "D.cone a' χ'"
interpret χ': cone J.comp C ?D a' χ' using χ' by auto
show "∃!f. «f : a' → a» ∧ D.cones_map f ?π = χ'"
proof
show "«χ' m : a' → a» ∧ D.cones_map (χ' m) ?π = χ'"
proof
show 1: "«χ' m : a' → a»"
using χ'.preserves_hom χ'.A.map_def J.arr_char J.dom_char J.cod_char
by auto
show "D.cones_map (χ' m) ?π = χ'"
proof
fix j
show "D.cones_map (χ' m) (λi. if i = m then a else null) j = χ' j"
using J.arr_char J.dom_char J.cod_char J.ide_char π.cone_axioms comp_cod_arr
apply (cases "j = m")
apply simp
using χ'.is_extensional by simp
qed
qed
show "⋀f. «f : a' → a» ∧ D.cones_map f ?π = χ' ⟹ f = χ' m"
proof -
fix f
assume f: "«f : a' → a» ∧ D.cones_map f ?π = χ'"
show "f = χ' m"
using assms f χ'.preserves_hom J.arr_char J.dom_char J.cod_char π.cone_axioms
comp_cod_arr
by auto
qed
qed
qed
show "∃π. product_cone J.comp C (λi. if i = m then a else null) a π"
using π.product_cone_axioms by blast
qed
qed
lemma has_unary_products:
assumes "card I = 1" and "I ≠ UNIV"
shows "has_products I"
proof -
obtain i where i: "I = {i}"
using assms card_1_singletonE by blast
obtain n where n: "n ∉ I"
using assms by auto
have "has_products {1 :: nat}"
proof (unfold has_products_def, intro conjI)
show "{1 :: nat} ≠ UNIV" by auto
show "∀(J :: nat comp) D.
discrete_diagram J (⋅) D ∧ Collect (partial_magma.arr J) = {1}
⟶ (∃a. has_as_product J D a)"
proof
fix J :: "nat comp"
show "∀D. discrete_diagram J (⋅) D ∧ Collect (partial_magma.arr J) = {1}
⟶ (∃a. has_as_product J D a)"
proof (intro allI impI)
fix D
assume D: "discrete_diagram J (⋅) D ∧ Collect (partial_magma.arr J) = {1}"
interpret D: discrete_diagram J C D
using D by auto
interpret J: discrete_category ‹{1 :: nat}› D.J.null
by (metis D D.J.not_arr_null discrete_category.intro mem_Collect_eq)
have 1: "has_as_product J.comp D (D 1)"
proof -
have "has_as_product J.comp (λi. if i = 1 then D 1 else null) (D 1)"
using ide_is_unary_product D.preserves_ide D.is_discrete D J.null_char
by (metis J.Null_not_in_Obj insertCI mem_Collect_eq)
moreover have "D = (λi. if i = 1 then D 1 else null)"
proof
fix j
show "D j = (if j = 1 then D 1 else null)"
using D D.is_extensional by auto
qed
ultimately show ?thesis by simp
qed
moreover have "J = J.comp"
proof -
have "⋀j j'. J j j' = J.comp j j'"
proof -
fix j j'
show "J j j' = J.comp j j'"
using J.comp_char D.is_discrete D
by (metis D.J.category_axioms D.J.ext D.J.ide_def J.null_char
category.seqE mem_Collect_eq)
qed
thus ?thesis by auto
qed
ultimately show "∃a. has_as_product J D a" by auto
qed
qed
qed
moreover have "bij_betw (λk. if k = 1 then i else n) {1 :: nat} I"
using i by (intro bij_betwI') auto
ultimately show "has_products I"
using assms has_products_preserved_by_bijection by blast
qed
end
subsection "Equalizers"
text‹
An \emph{equalizer} in a category @{term C} is a limit of a parallel pair
of arrows in @{term C}.
›
locale parallel_pair_diagram =
J: parallel_pair +
C: category C
for C :: "'c comp" (infixr "⋅" 55)
and f0 :: 'c
and f1 :: 'c +
assumes is_parallel: "C.par f0 f1"
begin
no_notation J.comp (infixr "⋅" 55)
notation J.comp (infixr "⋅⇩J" 55)
definition map
where "map ≡ (λj. if j = J.Zero then C.dom f0
else if j = J.One then C.cod f0
else if j = J.j0 then f0
else if j = J.j1 then f1
else C.null)"
lemma map_simp:
shows "map J.Zero = C.dom f0"
and "map J.One = C.cod f0"
and "map J.j0 = f0"
and "map J.j1 = f1"
proof -
show "map J.Zero = C.dom f0"
using map_def by metis
show "map J.One = C.cod f0"
using map_def J.Zero_not_eq_One by metis
show "map J.j0 = f0"
using map_def J.Zero_not_eq_j0 J.One_not_eq_j0 by metis
show "map J.j1 = f1"
using map_def J.Zero_not_eq_j1 J.One_not_eq_j1 J.j0_not_eq_j1 by metis
qed
end
sublocale parallel_pair_diagram ⊆ diagram J.comp C map
apply unfold_locales
apply (simp add: J.arr_char map_def)
using map_def is_parallel J.arr_char J.cod_simp J.dom_simp
apply auto[2]
proof -
show 1: "⋀j. J.arr j ⟹ C.cod (map j) = map (J.cod j)"
proof -
fix j
assume j: "J.arr j"
show "C.cod (map j) = map (J.cod j)"
proof -
have "j = J.Zero ∨ j = J.One ⟹ ?thesis" using is_parallel map_def by auto
moreover have "j = J.j0 ∨ j = J.j1 ⟹ ?thesis"
using is_parallel map_def J.Zero_not_eq_j0 J.One_not_eq_j0 J.Zero_not_eq_One
J.Zero_not_eq_j1 J.One_not_eq_j1 J.Zero_not_eq_One J.cod_simp
by presburger
ultimately show ?thesis using j J.arr_char by fast
qed
qed
next
fix j j'
assume jj': "J.seq j' j"
show "map (j' ⋅⇩J j) = map j' ⋅ map j"
proof -
have 1: "(j = J.Zero ∧ j' ≠ J.One) ∨ (j ≠ J.Zero ∧ j' = J.One)"
using jj' J.seq_char by blast
moreover have "j = J.Zero ∧ j' ≠ J.One ⟹ ?thesis"
using jj' map_def is_parallel J.arr_char J.cod_simp J.dom_simp J.seq_char
by (metis (no_types, lifting) C.arr_dom_iff_arr C.comp_arr_dom C.dom_dom
J.comp_arr_dom)
moreover have "j ≠ J.Zero ∧ j' = J.One ⟹ ?thesis"
using jj' J.ide_char map_def J.Zero_not_eq_One is_parallel
by (metis (no_types, lifting) C.arr_cod_iff_arr C.comp_arr_dom C.comp_cod_arr
C.comp_ide_arr C.ext C.ide_cod J.comp_simp(2))
ultimately show ?thesis by blast
qed
qed
context parallel_pair_diagram
begin
definition mkCone
where "mkCone e ≡ λj. if J.arr j then if j = J.Zero then e else f0 ⋅ e else C.null"
abbreviation is_equalized_by
where "is_equalized_by e ≡ C.seq f0 e ∧ f0 ⋅ e = f1 ⋅ e"
abbreviation has_as_equalizer
where "has_as_equalizer e ≡ limit_cone (C.dom e) (mkCone e)"
lemma cone_mkCone:
assumes "is_equalized_by e"
shows "cone (C.dom e) (mkCone e)"
proof -
interpret E: constant_functor J.comp C ‹C.dom e›
apply unfold_locales using assms by auto
show "cone (C.dom e) (mkCone e)"
using assms mkCone_def apply unfold_locales
apply auto[2]
using C.dom_comp C.seqE C.cod_comp J.Zero_not_eq_One J.arr_char' J.cod_char map_def
apply (metis (no_types, lifting) C.not_arr_null parallel_pair.cod_simp(1) preserves_arr)
proof -
fix j
assume j: "J.arr j"
show "map j ⋅ mkCone e (J.dom j) = mkCone e j"
proof -
have 1: "∀a. if a = J.Zero then map a = C.dom f0
else if a = J.One then map a = C.cod f0
else if a = J.j0 then map a = f0
else if a = J.j1 then map a = f1
else map a = C.null"
using map_def by auto
hence 2: "map j = f1 ∨ j = J.One ∨ j = J.Zero ∨ j = J.j0"
using j parallel_pair.arr_char by meson
have "j = J.Zero ∨ map j ⋅ mkCone e (J.dom j) = mkCone e j"
using assms j 1 2 mkCone_def C.cod_comp
by (metis (no_types, lifting) C.comp_cod_arr J.arr_char J.dom_simp(2-4) is_parallel)
thus ?thesis
using assms 1 j
by (metis (no_types, lifting) C.comp_cod_arr C.seqE mkCone_def J.dom_simp(1))
qed
next
show "⋀j. J.arr j ⟹ mkCone e (J.cod j) ⋅ E.map j = mkCone e j"
proof -
fix j
assume j: "J.arr j"
have "J.cod j = J.Zero ⟹ mkCone e (J.cod j) ⋅ E.map j = mkCone e j"
unfolding mkCone_def
using assms j J.arr_char J.cod_char C.comp_arr_dom mkCone_def J.Zero_not_eq_One
by (metis (no_types, lifting) C.seqE E.map_simp)
moreover have "J.cod j ≠ J.Zero ⟹ mkCone e (J.cod j) ⋅ E.map j = mkCone e j"
unfolding mkCone_def
using assms j C.comp_arr_dom by auto
ultimately show "mkCone e (J.cod j) ⋅ E.map j = mkCone e j" by blast
qed
qed
qed
lemma is_equalized_by_cone:
assumes "cone a χ"
shows "is_equalized_by (χ (J.Zero))"
proof -
interpret χ: cone J.comp C map a χ
using assms by auto
show ?thesis
using assms J.arr_char J.dom_char J.cod_char
J.One_not_eq_j0 J.One_not_eq_j1 J.Zero_not_eq_j0 J.Zero_not_eq_j1 J.j0_not_eq_j1
by (metis (no_types, lifting) Limit.cone_def χ.is_natural_1 χ.naturality
χ.preserves_reflects_arr constant_functor.map_simp map_simp(3) map_simp(4))
qed
lemma mkCone_cone:
assumes "cone a χ"
shows "mkCone (χ J.Zero) = χ"
proof -
interpret χ: cone J.comp C map a χ
using assms by auto
have 1: "is_equalized_by (χ J.Zero)"
using assms is_equalized_by_cone by blast
show ?thesis
proof
fix j
have "j = J.Zero ⟹ mkCone (χ J.Zero) j = χ j"
using mkCone_def χ.is_extensional by simp
moreover have "j = J.One ∨ j = J.j0 ∨ j = J.j1 ⟹ mkCone (χ J.Zero) j = χ j"
using J.arr_char J.cod_char J.dom_char J.seq_char mkCone_def
χ.is_natural_1 χ.is_natural_2 χ.A.map_simp map_def
by (metis (no_types, lifting) J.Zero_not_eq_j0 J.dom_simp(2))
ultimately have "J.arr j ⟹ mkCone (χ J.Zero) j = χ j"
using J.arr_char by auto
thus "mkCone (χ J.Zero) j = χ j"
using mkCone_def χ.is_extensional by fastforce
qed
qed
end
locale equalizer_cone =
J: parallel_pair +
C: category C +
D: parallel_pair_diagram C f0 f1 +
limit_cone J.comp C D.map "C.dom e" "D.mkCone e"
for C :: "'c comp" (infixr "⋅" 55)
and f0 :: 'c
and f1 :: 'c
and e :: 'c
begin
lemma equalizes:
shows "D.is_equalized_by e"
proof
show 1: "C.seq f0 e"
proof (intro C.seqI)
show "C.arr e" using ide_apex C.arr_dom_iff_arr by fastforce
show "C.arr f0"
using D.map_simp D.preserves_arr J.arr_char by metis
show "C.dom f0 = C.cod e"
using J.arr_char J.ide_char D.mkCone_def D.map_simp preserves_cod [of J.Zero]
by auto
qed
hence 2: "C.seq f1 e"
using D.is_parallel by fastforce
show "f0 ⋅ e = f1 ⋅ e"
using D.map_simp D.mkCone_def J.arr_char naturality [of J.j0] naturality [of J.j1]
by force
qed
lemma is_universal':
assumes "D.is_equalized_by e'"
shows "∃!h. «h : C.dom e' → C.dom e» ∧ e ⋅ h = e'"
proof -
have "D.cone (C.dom e') (D.mkCone e')"
using assms D.cone_mkCone by blast
moreover have 0: "D.cone (C.dom e) (D.mkCone e)" ..
ultimately have 1: "∃!h. «h : C.dom e' → C.dom e» ∧
D.cones_map h (D.mkCone e) = D.mkCone e'"
using is_universal [of "C.dom e'" "D.mkCone e'"] by auto
have 2: "⋀h. «h : C.dom e' → C.dom e» ⟹
D.cones_map h (D.mkCone e) = D.mkCone e' ⟷ e ⋅ h = e'"
proof -
fix h
assume h: "«h : C.dom e' → C.dom e»"
show "D.cones_map h (D.mkCone e) = D.mkCone e' ⟷ e ⋅ h = e'"
proof
assume 3: "D.cones_map h (D.mkCone e) = D.mkCone e'"
show "e ⋅ h = e'"
proof -
have "e' = D.mkCone e' J.Zero"
using D.mkCone_def J.arr_char by simp
also have "... = D.cones_map h (D.mkCone e) J.Zero"
using 3 by simp
also have "... = e ⋅ h"
using 0 h D.mkCone_def J.arr_char by auto
finally show ?thesis by auto
qed
next
assume e': "e ⋅ h = e'"
show "D.cones_map h (D.mkCone e) = D.mkCone e'"
proof
fix j
have "¬J.arr j ⟹ D.cones_map h (D.mkCone e) j = D.mkCone e' j"
using h cone_axioms D.mkCone_def by auto
moreover have "j = J.Zero ⟹ D.cones_map h (D.mkCone e) j = D.mkCone e' j"
using h e' cone_χ D.mkCone_def J.arr_char [of J.Zero] by force
moreover have
"J.arr j ∧ j ≠ J.Zero ⟹ D.cones_map h (D.mkCone e) j = D.mkCone e' j"
proof -
assume j: "J.arr j ∧ j ≠ J.Zero"
have "D.cones_map h (D.mkCone e) j = C (D.mkCone e j) h"
using j h equalizes D.mkCone_def D.cone_mkCone J.arr_char
J.Zero_not_eq_One J.Zero_not_eq_j0 J.Zero_not_eq_j1
by auto
also have "... = (f0 ⋅ e) ⋅ h"
using j D.mkCone_def J.arr_char J.Zero_not_eq_One J.Zero_not_eq_j0
J.Zero_not_eq_j1
by auto
also have "... = f0 ⋅ e ⋅ h"
using h equalizes C.comp_assoc by blast
also have "... = D.mkCone e' j"
using j e' h equalizes D.mkCone_def J.arr_char [of J.One] J.Zero_not_eq_One
by auto
finally show ?thesis by auto
qed
ultimately show "D.cones_map h (D.mkCone e) j = D.mkCone e' j" by blast
qed
qed
qed
thus ?thesis using 1 by blast
qed
lemma induced_arrowI':
assumes "D.is_equalized_by e'"
shows "«induced_arrow (C.dom e') (D.mkCone e') : C.dom e' → C.dom e»"
and "e ⋅ induced_arrow (C.dom e') (D.mkCone e') = e'"
proof -
interpret A': constant_functor J.comp C ‹C.dom e'›
using assms by (unfold_locales, auto)
have cone: "D.cone (C.dom e') (D.mkCone e')"
using assms D.cone_mkCone [of e'] by blast
have "e ⋅ induced_arrow (C.dom e') (D.mkCone e') =
D.cones_map (induced_arrow (C.dom e') (D.mkCone e')) (D.mkCone e) J.Zero"
using cone induced_arrowI(1) D.mkCone_def J.arr_char cone_χ by force
also have "... = e'"
proof -
have
"D.cones_map (induced_arrow (C.dom e') (D.mkCone e')) (D.mkCone e) =
D.mkCone e'"
using cone induced_arrowI by blast
thus ?thesis
using J.arr_char D.mkCone_def by simp
qed
finally have 1: "e ⋅ induced_arrow (C.dom e') (D.mkCone e') = e'"
by auto
show "«induced_arrow (C.dom e') (D.mkCone e') : C.dom e' → C.dom e»"
using 1 cone induced_arrowI by simp
show "e ⋅ induced_arrow (C.dom e') (D.mkCone e') = e'"
using 1 cone induced_arrowI by simp
qed
end
context category
begin
definition has_as_equalizer
where "has_as_equalizer f0 f1 e ≡ par f0 f1 ∧ parallel_pair_diagram.has_as_equalizer C f0 f1 e"
definition has_equalizers
where "has_equalizers = (∀f0 f1. par f0 f1 ⟶ (∃e. has_as_equalizer f0 f1 e))"
end
section "Limits by Products and Equalizers"
text‹
A category with equalizers has limits of shape @{term J} if it has products
indexed by the set of arrows of @{term J} and the set of objects of @{term J}.
The proof is patterned after \cite{MacLane}, Theorem 2, page 109:
\begin{quotation}
\noindent
``The limit of ‹F: J → C› is the equalizer ‹e›
of ‹f, g: Π⇩i F⇩i → Π⇩u F⇩c⇩o⇩d ⇩u (u ∈ arr J, i ∈ J)›
where ‹p⇩u f = p⇩c⇩o⇩d ⇩u›, ‹p⇩u g = F⇩u o p⇩d⇩o⇩m ⇩u›;
the limiting cone ‹μ› is ‹μ⇩j = p⇩j e›, for ‹j ∈ J›.''
\end{quotation}
›
locale category_with_equalizers =
category C
for C :: "'c comp" (infixr "⋅" 55) +
assumes has_equalizers: "has_equalizers"
begin
lemma has_limits_if_has_products:
fixes J :: "'j comp" (infixr "⋅⇩J" 55)
assumes "category J" and "has_products (Collect (partial_magma.ide J))"
and "has_products (Collect (partial_magma.arr J))"
shows "has_limits_of_shape J"
proof (unfold has_limits_of_shape_def)
interpret J: category J using assms(1) by auto
have "⋀D. diagram J C D ⟹ (∃a χ. limit_cone J C D a χ)"
proof -
fix D
assume D: "diagram J C D"
interpret D: diagram J C D using D by auto
text‹
First, construct the two required products and their cones.
›
interpret Obj: discrete_category ‹Collect J.ide› J.null
using J.not_arr_null J.ideD(1) mem_Collect_eq by (unfold_locales, blast)
interpret Δo: discrete_diagram_from_map ‹Collect J.ide› C D J.null
using D.preserves_ide by (unfold_locales, auto)
have "∃p. has_as_product Obj.comp Δo.map p"
using assms(2) Δo.diagram_axioms has_products_def Obj.arr_char
by (metis (no_types, lifting) Collect_cong Δo.discrete_diagram_axioms mem_Collect_eq)
from this obtain Πo πo where πo: "product_cone Obj.comp C Δo.map Πo πo"
using ex_productE [of Obj.comp Δo.map] by auto
interpret πo: product_cone Obj.comp C Δo.map Πo πo using πo by auto
have πo_in_hom: "⋀j. Obj.arr j ⟹ «πo j : Πo → D j»"
using πo.preserves_dom πo.preserves_cod Δo.map_def by auto
interpret Arr: discrete_category ‹Collect J.arr› J.null
using J.not_arr_null by (unfold_locales, blast)
interpret Δa: discrete_diagram_from_map ‹Collect J.arr› C ‹D o J.cod› J.null
by (unfold_locales, auto)
have "∃p. has_as_product Arr.comp Δa.map p"
using assms(3) has_products_def [of "Collect J.arr"] Δa.discrete_diagram_axioms
by blast
from this obtain Πa πa where πa: "product_cone Arr.comp C Δa.map Πa πa"
using ex_productE [of Arr.comp Δa.map] by auto
interpret πa: product_cone Arr.comp C Δa.map Πa πa using πa by auto
have πa_in_hom: "⋀j. Arr.arr j ⟹ «πa j : Πa → D (J.cod j)»"
using πa.preserves_cod πa.preserves_dom Δa.map_def by auto
text‹
Next, construct a parallel pair of arrows ‹f, g: Πo → Πa›
that expresses the commutativity constraints imposed by the diagram.
›
interpret Πo: constant_functor Arr.comp C Πo
using πo.ide_apex by (unfold_locales, auto)
let ?χ = "λj. if Arr.arr j then πo (J.cod j) else null"
interpret χ: cone Arr.comp C Δa.map Πo ?χ
using πo.ide_apex πo_in_hom Δa.map_def Δo.map_def Δo.is_discrete πo.is_natural_2
comp_cod_arr
by (unfold_locales, auto)
let ?f = "πa.induced_arrow Πo ?χ"
have f_in_hom: "«?f : Πo → Πa»"
using χ.cone_axioms πa.induced_arrowI by blast
have f_map: "Δa.cones_map ?f πa = ?χ"
using χ.cone_axioms πa.induced_arrowI by blast
have ff: "⋀j. J.arr j ⟹ πa j ⋅ ?f = πo (J.cod j)"
proof -
fix j
assume j: "J.arr j"
have "πa j ⋅ ?f = Δa.cones_map ?f πa j"
using f_in_hom πa.is_cone πa.is_extensional by auto
also have "... = πo (J.cod j)"
using j f_map by fastforce
finally show "πa j ⋅ ?f = πo (J.cod j)" by auto
qed
let ?χ' = "λj. if Arr.arr j then D j ⋅ πo (J.dom j) else null"
interpret χ': cone Arr.comp C Δa.map Πo ?χ'
using πo.ide_apex πo_in_hom Δo.map_def Δa.map_def comp_arr_dom comp_cod_arr
by (unfold_locales, auto)
let ?g = "πa.induced_arrow Πo ?χ'"
have g_in_hom: "«?g : Πo → Πa»"
using χ'.cone_axioms πa.induced_arrowI by blast
have g_map: "Δa.cones_map ?g πa = ?χ'"
using χ'.cone_axioms πa.induced_arrowI by blast
have gg: "⋀j. J.arr j ⟹ πa j ⋅ ?g = D j ⋅ πo (J.dom j)"
proof -
fix j
assume j: "J.arr j"
have "πa j ⋅ ?g = Δa.cones_map ?g πa j"
using g_in_hom πa.is_cone πa.is_extensional by force
also have "... = D j ⋅ πo (J.dom j)"
using j g_map by fastforce
finally show "πa j ⋅ ?g = D j ⋅ πo (J.dom j)" by auto
qed
interpret PP: parallel_pair_diagram C ?f ?g
using f_in_hom g_in_hom
by (elim in_homE, unfold_locales, auto)
from PP.is_parallel obtain e where equ: "PP.has_as_equalizer e"
using has_equalizers has_equalizers_def has_as_equalizer_def by blast
interpret EQU: limit_cone PP.J.comp C PP.map ‹dom e› ‹PP.mkCone e›
using equ by auto
interpret EQU: equalizer_cone C ?f ?g e ..
text‹
An arrow @{term h} with @{term "cod h = Πo"} equalizes @{term f} and @{term g}
if and only if it satisfies the commutativity condition required for a cone over
@{term D}.
›
have E: "⋀h. «h : dom h → Πo» ⟹
?f ⋅ h = ?g ⋅ h ⟷ (∀j. J.arr j ⟶ ?χ j ⋅ h = ?χ' j ⋅ h)"
proof
fix h
assume h: "«h : dom h → Πo»"
show "?f ⋅ h = ?g ⋅ h ⟹ ∀j. J.arr j ⟶ ?χ j ⋅ h = ?χ' j ⋅ h"
proof -
assume E: "?f ⋅ h = ?g ⋅ h"
have "⋀j. J.arr j ⟹ ?χ j ⋅ h = ?χ' j ⋅ h"
proof -
fix j
assume j: "J.arr j"
have "?χ j ⋅ h = Δa.cones_map ?f πa j ⋅ h"
using j f_map by fastforce
also have "... = πa j ⋅ ?f ⋅ h"
using j f_in_hom Δa.map_def πa.cone_χ comp_assoc by auto
also have "... = πa j ⋅ ?g ⋅ h"
using j E by simp
also have "... = Δa.cones_map ?g πa j ⋅ h"
using j g_in_hom Δa.map_def πa.cone_χ comp_assoc by auto
also have "... = ?χ' j ⋅ h"
using j g_map by force
finally show "?χ j ⋅ h = ?χ' j ⋅ h" by auto
qed
thus "∀j. J.arr j ⟶ ?χ j ⋅ h = ?χ' j ⋅ h" by blast
qed
show "∀j. J.arr j ⟶ ?χ j ⋅ h = ?χ' j ⋅ h ⟹ ?f ⋅ h = ?g ⋅ h"
proof -
assume 1: "∀j. J.arr j ⟶ ?χ j ⋅ h = ?χ' j ⋅ h"
have 2: "⋀j. j ∈ Collect J.arr ⟹ πa j ⋅ ?f ⋅ h = πa j ⋅ ?g ⋅ h"
proof -
fix j
assume j: "j ∈ Collect J.arr"
have "πa j ⋅ ?f ⋅ h = (πa j ⋅ ?f) ⋅ h"
using comp_assoc by simp
also have "... = ?χ j ⋅ h"
proof -
have "πa j ⋅ ?f = Δa.cones_map ?f πa j"
using j f_in_hom πa.cone_axioms Δa.map_def πa.cone_χ by auto
thus ?thesis using f_map by fastforce
qed
also have "... = ?χ' j ⋅ h"
using 1 j by auto
also have "... = (πa j ⋅ ?g) ⋅ h"
proof -
have "πa j ⋅ ?g = Δa.cones_map ?g πa j"
using j g_in_hom πa.cone_axioms Δa.map_def πa.cone_χ by auto
thus ?thesis using g_map by simp
qed
also have "... = πa j ⋅ ?g ⋅ h"
using comp_assoc by simp
finally show "πa j ⋅ ?f ⋅ h = πa j ⋅ ?g ⋅ h"
by auto
qed
show "C ?f h = C ?g h"
proof -
have "⋀j. Arr.arr j ⟹ «πa j ⋅ ?f ⋅ h : dom h → Δa.map j»"
using f_in_hom h πa_in_hom by (elim in_homE, auto)
hence 3: "∃!k. «k : dom h → Πa» ∧ (∀j. Arr.arr j ⟶ πa j ⋅ k = πa j ⋅ ?f ⋅ h)"
using h πa πa.is_universal' [of "dom h" "λj. πa j ⋅ ?f ⋅ h"] Δa.map_def
ide_dom [of h]
by blast
have 4: "⋀P x x'. ∃!k. P k x ⟹ P x x ⟹ P x' x ⟹ x' = x" by auto
let ?P = "λ k x. «k : dom h → Πa» ∧
(∀j. j ∈ Collect J.arr ⟶ πa j ⋅ k = πa j ⋅ x)"
have "?P (?g ⋅ h) (?g ⋅ h)"
using g_in_hom h by force
moreover have "?P (?f ⋅ h) (?g ⋅ h)"
using 2 f_in_hom g_in_hom h by force
ultimately show ?thesis
using 3 4 [of ?P "?f ⋅ h" "?g ⋅ h"] by auto
qed
qed
qed
have E': "⋀e. «e : dom e → Πo» ⟹
?f ⋅ e = ?g ⋅ e ⟷
(∀j. J.arr j ⟶
(D (J.cod j) ⋅ πo (J.cod j) ⋅ e) ⋅ dom e = D j ⋅ πo (J.dom j) ⋅ e)"
proof -
have 1: "⋀e j. «e : dom e → Πo» ⟹ J.arr j ⟹
?χ j ⋅ e = (D (J.cod j) ⋅ πo (J.cod j) ⋅ e) ⋅ dom e"
proof -
fix e j
assume e: "«e : dom e → Πo»"
assume j: "J.arr j"
have "«πo (J.cod j) ⋅ e : dom e → D (J.cod j)»"
using e j πo_in_hom by auto
thus "?χ j ⋅ e = (D (J.cod j) ⋅ πo (J.cod j) ⋅ e) ⋅ dom e"
using j comp_arr_dom comp_cod_arr by (elim in_homE, auto)
qed
have 2: "⋀e j. «e : dom e → Πo» ⟹ J.arr j ⟹ ?χ' j ⋅ e = D j ⋅ πo (J.dom j) ⋅ e"
proof -
fix e j
assume e: "«e : dom e → Πo»"
assume j: "J.arr j"
show "?χ' j ⋅ e = D j ⋅ πo (J.dom j) ⋅ e"
using j comp_assoc by fastforce
qed
show "⋀e. «e : dom e → Πo» ⟹
?f ⋅ e = ?g ⋅ e ⟷
(∀j. J.arr j ⟶
(D (J.cod j) ⋅ πo (J.cod j) ⋅ e) ⋅ dom e = D j ⋅ πo (J.dom j) ⋅ e)"
using 1 2 E by presburger
qed
text‹
The composites of @{term e} with the projections from the product @{term Πo}
determine a limit cone @{term μ} for @{term D}. The component of @{term μ}
at an object @{term j} of @{term[source=true] J} is the composite @{term "C (πo j) e"}.
However, we need to extend @{term μ} to all arrows @{term j} of @{term[source=true] J},
so the correct definition is @{term "μ j = C (D j) (C (πo (J.dom j)) e)"}.
›
have e_in_hom: "«e : dom e → Πo»"
using EQU.equalizes f_in_hom in_homI
by (metis (no_types, lifting) seqE in_homE)
have e_map: "C ?f e = C ?g e"
using EQU.equalizes f_in_hom in_homI by fastforce
interpret domE: constant_functor J C ‹dom e›
using e_in_hom by (unfold_locales, auto)
let ?μ = "λj. if J.arr j then D j ⋅ πo (J.dom j) ⋅ e else null"
have μ: "⋀j. J.arr j ⟹ «?μ j : dom e → D (J.cod j)»"
proof -
fix j
assume j: "J.arr j"
show "«?μ j : dom e → D (J.cod j)»"
using j e_in_hom πo_in_hom [of "J.dom j"] by auto
qed
interpret μ: cone J C D ‹dom e› ?μ
using μ comp_cod_arr e_in_hom e_map E'
apply unfold_locales
apply auto
by (metis D.is_natural_1 comp_assoc)
text‹
If @{term τ} is any cone over @{term D} then @{term τ} restricts to a cone over
@{term Δo} for which the induced arrow to @{term Πo} equalizes @{term f} and @{term g}.
›
have R: "⋀a τ. cone J C D a τ ⟹
cone Obj.comp C Δo.map a (Δo.mkCone τ) ∧
?f ⋅ πo.induced_arrow a (Δo.mkCone τ)
= ?g ⋅ πo.induced_arrow a (Δo.mkCone τ)"
proof -
fix a τ
assume cone_τ: "cone J C D a τ"
interpret τ: cone J C D a τ using cone_τ by auto
interpret A: constant_functor Obj.comp C a
using τ.ide_apex by (unfold_locales, auto)
interpret τo: cone Obj.comp C Δo.map a ‹Δo.mkCone τ›
using A.value_is_ide Δo.map_def comp_cod_arr comp_arr_dom
by (unfold_locales, auto)
let ?e = "πo.induced_arrow a (Δo.mkCone τ)"
have mkCone_τ: "Δo.mkCone τ ∈ Δo.cones a"
using τo.cone_axioms by auto
have e: "«?e : a → Πo»"
using mkCone_τ πo.induced_arrowI by simp
have ee: "⋀j. J.ide j ⟹ πo j ⋅ ?e = τ j"
proof -
fix j
assume j: "J.ide j"
have "πo j ⋅ ?e = Δo.cones_map ?e πo j"
using j e πo.cone_axioms by force
also have "... = Δo.mkCone τ j"
using j mkCone_τ πo.induced_arrowI [of "Δo.mkCone τ" a] by fastforce
also have "... = τ j"
using j by simp
finally show "πo j ⋅ ?e = τ j" by auto
qed
have "⋀j. J.arr j ⟹
(D (J.cod j) ⋅ πo (J.cod j) ⋅ ?e) ⋅ dom ?e = D j ⋅ πo (J.dom j) ⋅ ?e"
proof -
fix j
assume j: "J.arr j"
have 1: "«πo (J.cod j) : Πo → D (J.cod j)»" using j πo_in_hom by simp
have 2: "(D (J.cod j) ⋅ πo (J.cod j) ⋅ ?e) ⋅ dom ?e
= D (J.cod j) ⋅ πo (J.cod j) ⋅ ?e"
proof -
have "seq (D (J.cod j)) (πo (J.cod j))"
using j 1 by auto
moreover have "seq (πo (J.cod j)) ?e"
using j e by fastforce
ultimately show ?thesis using comp_arr_dom by auto
qed
also have 3: "... = πo (J.cod j) ⋅ ?e"
using j e 1 comp_cod_arr by (elim in_homE, auto)
also have "... = D j ⋅ πo (J.dom j) ⋅ ?e"
using j e ee 2 3 τ.naturality τ.A.map_simp τ.ide_apex comp_cod_arr by auto
finally show "(D (J.cod j) ⋅ πo (J.cod j) ⋅ ?e) ⋅ dom ?e = D j ⋅ πo (J.dom j) ⋅ ?e"
by auto
qed
hence "C ?f ?e = C ?g ?e"
using E' πo.induced_arrowI τo.cone_axioms mem_Collect_eq by blast
thus "cone Obj.comp C Δo.map a (Δo.mkCone τ) ∧ C ?f ?e = C ?g ?e"
using τo.cone_axioms by auto
qed
text‹
Finally, show that @{term μ} is a limit cone.
›
interpret μ: limit_cone J C D ‹dom e› ?μ
proof
fix a τ
assume cone_τ: "cone J C D a τ"
interpret τ: cone J C D a τ using cone_τ by auto
interpret A: constant_functor Obj.comp C a
using τ.ide_apex by unfold_locales auto
have cone_τo: "cone Obj.comp C Δo.map a (Δo.mkCone τ)"
using A.value_is_ide Δo.map_def D.preserves_ide comp_cod_arr comp_arr_dom
τ.preserves_hom
by unfold_locales auto
show "∃!h. «h : a → dom e» ∧ D.cones_map h ?μ = τ"
proof
let ?e' = "πo.induced_arrow a (Δo.mkCone τ)"
have e'_in_hom: "«?e' : a → Πo»"
using cone_τ R πo.induced_arrowI by auto
have e'_map: "?f ⋅ ?e' = ?g ⋅ ?e' ∧ Δo.cones_map ?e' πo = Δo.mkCone τ"
using cone_τ R πo.induced_arrowI [of "Δo.mkCone τ" a] by auto
have equ: "PP.is_equalized_by ?e'"
using e'_map e'_in_hom f_in_hom seqI' by blast
let ?h = "EQU.induced_arrow a (PP.mkCone ?e')"
have h_in_hom: "«?h : a → dom e»"
using EQU.induced_arrowI PP.cone_mkCone [of ?e'] e'_in_hom equ by fastforce
have h_map: "PP.cones_map ?h (PP.mkCone e) = PP.mkCone ?e'"
using EQU.induced_arrowI [of "PP.mkCone ?e'" a] PP.cone_mkCone [of ?e']
e'_in_hom equ
by fastforce
have 3: "D.cones_map ?h ?μ = τ"
proof
fix j
have "¬J.arr j ⟹ D.cones_map ?h ?μ j = τ j"
using h_in_hom μ.cone_axioms cone_τ τ.is_extensional by force
moreover have "J.arr j ⟹ D.cones_map ?h ?μ j = τ j"
proof -
fix j
assume j: "J.arr j"
have 1: "«πo (J.dom j) ⋅ e : dom e → D (J.dom j)»"
using j e_in_hom πo_in_hom [of "J.dom j"] by auto
have "D.cones_map ?h ?μ j = ?μ j ⋅ ?h"
using h_in_hom j μ.cone_axioms by auto
also have "... = D j ⋅ (πo (J.dom j) ⋅ e) ⋅ ?h"
using j comp_assoc by simp
also have "... = D j ⋅ τ (J.dom j)"
proof -
have "(πo (J.dom j) ⋅ e) ⋅ ?h = τ (J.dom j)"
proof -
have "(πo (J.dom j) ⋅ e) ⋅ ?h = πo (J.dom j) ⋅ e ⋅ ?h"
using j 1 e_in_hom h_in_hom πo arrI comp_assoc by auto
also have "... = πo (J.dom j) ⋅ ?e'"
using equ e'_in_hom EQU.induced_arrowI' [of ?e'] by auto
also have "... = Δo.cones_map ?e' πo (J.dom j)"
using j e'_in_hom πo.cone_axioms by auto
also have "... = τ (J.dom j)"
using j e'_map by simp
finally show ?thesis by auto
qed
thus ?thesis by simp
qed
also have "... = τ j"
using j τ.is_natural_1 by simp
finally show "D.cones_map ?h ?μ j = τ j" by auto
qed
ultimately show "D.cones_map ?h ?μ j = τ j" by auto
qed
show "«?h : a → dom e» ∧ D.cones_map ?h ?μ = τ"
using h_in_hom 3 by simp
show "⋀h'. «h' : a → dom e» ∧ D.cones_map h' ?μ = τ ⟹ h' = ?h"
proof -
fix h'
assume h': "«h' : a → dom e» ∧ D.cones_map h' ?μ = τ"
have h'_in_hom: "«h' : a → dom e»" using h' by simp
have h'_map: "D.cones_map h' ?μ = τ" using h' by simp
show "h' = ?h"
proof -
have 1: "«e ⋅ h' : a → Πo» ∧ ?f ⋅ e ⋅ h' = ?g ⋅ e ⋅ h' ∧
Δo.cones_map (C e h') πo = Δo.mkCone τ"
proof -
have 2: "«e ⋅ h' : a → Πo»" using h'_in_hom e_in_hom by auto
moreover have "?f ⋅ e ⋅ h' = ?g ⋅ e ⋅ h'"
proof -
have "?f ⋅ e ⋅ h' = (?f ⋅ e) ⋅ h'"
using comp_assoc by auto
also have "... = ?g ⋅ e ⋅ h'"
using EQU.equalizes comp_assoc by auto
finally show ?thesis by auto
qed
moreover have "Δo.cones_map (e ⋅ h') πo = Δo.mkCone τ"
proof
have "Δo.cones_map (e ⋅ h') πo = Δo.cones_map h' (Δo.cones_map e πo)"
using πo.cone_axioms e_in_hom h'_in_hom Δo.cones_map_comp [of e h']
by fastforce
fix j
have "¬Obj.arr j ⟹ Δo.cones_map (e ⋅ h') πo j = Δo.mkCone τ j"
using 2 e_in_hom h'_in_hom πo.cone_axioms by auto
moreover have "Obj.arr j ⟹ Δo.cones_map (e ⋅ h') πo j = Δo.mkCone τ j"
proof -
assume j: "Obj.arr j"
have "Δo.cones_map (e ⋅ h') πo j = πo j ⋅ e ⋅ h'"
using 2 j πo.cone_axioms by auto
also have "... = (πo j ⋅ e) ⋅ h'"
using comp_assoc by auto
also have "... = Δo.mkCone ?μ j ⋅ h'"
using j e_in_hom πo_in_hom comp_ide_arr [of "D j" "πo j ⋅ e"]
by fastforce
also have "... = Δo.mkCone τ j"
using j h' μ.cone_axioms mem_Collect_eq by auto
finally show "Δo.cones_map (e ⋅ h') πo j = Δo.mkCone τ j" by auto
qed
ultimately show "Δo.cones_map (e ⋅ h') πo j = Δo.mkCone τ j" by auto
qed
ultimately show ?thesis by auto
qed
have "«e ⋅ h' : a → Πo»" using 1 by simp
moreover have "e ⋅ h' = ?e'"
using 1 cone_τo e'_in_hom e'_map πo.is_universal πo by blast
ultimately show "h' = ?h"
using 1 h'_in_hom h'_map EQU.is_universal' [of "e ⋅ h'"]
EQU.induced_arrowI' [of ?e'] equ
by (elim in_homE) auto
qed
qed
qed
qed
have "limit_cone J C D (dom e) ?μ" ..
thus "∃a μ. limit_cone J C D a μ" by auto
qed
thus "∀D. diagram J C D ⟶ (∃a μ. limit_cone J C D a μ)" by blast
qed
end
section "Limits in a Set Category"
text‹
In this section, we consider the special case of limits in a set category.
›
locale diagram_in_set_category =
J: category J +
S: set_category S 𝔄 +
diagram J S D
for J :: "'j comp" (infixr "⋅⇩J" 55)
and S :: "'s comp" (infixr "⋅" 55)
and 𝔄 :: "'a rel"
and D :: "'j ⇒ 's"
begin
notation S.in_hom ("«_ : _ → _»")
text‹
An object @{term a} of a set category @{term[source=true] S} is a limit of a diagram in
@{term[source=true] S} if and only if there is a bijection between the set
@{term "S.hom S.unity a"} of points of @{term a} and the set of cones over the diagram
that have apex @{term S.unity}.
›
lemma limits_are_sets_of_cones:
shows "has_as_limit a ⟷ S.ide a ∧ (∃φ. bij_betw φ (S.hom S.unity a) (cones S.unity))"
proof
text‹
If ‹has_limit a›, then by the universal property of the limit cone,
composition in @{term[source=true] S} yields a bijection between @{term "S.hom S.unity a"}
and @{term "cones S.unity"}.
›
assume a: "has_as_limit a"
hence "S.ide a"
using limit_cone_def cone.ide_apex by metis
from a obtain χ where χ: "limit_cone a χ" by auto
interpret χ: limit_cone J S D a χ using χ by auto
have "bij_betw (λf. cones_map f χ) (S.hom S.unity a) (cones S.unity)"
using χ.bij_betw_hom_and_cones S.ide_unity by simp
thus "S.ide a ∧ (∃φ. bij_betw φ (S.hom S.unity a) (cones S.unity))"
using ‹S.ide a› by blast
next
text‹
Conversely, an arbitrary bijection @{term φ} between @{term "S.hom S.unity a"}
and cones unity extends pointwise to a natural bijection @{term "Φ a'"} between
@{term "S.hom a' a"} and @{term "cones a'"}, showing that @{term a} is a limit.
In more detail, the hypotheses give us a correspondence between points of @{term a}
and cones with apex @{term "S.unity"}. We extend this to a correspondence between
functions to @{term a} and general cones, with each arrow from @{term a'} to @{term a}
determining a cone with apex @{term a'}. If @{term "f ∈ hom a' a"} then composition
with @{term f} takes each point @{term y} of @{term a'} to the point @{term "S f y"}
of @{term a}. To this we may apply the given bijection @{term φ} to obtain
@{term "φ (S f y) ∈ cones S.unity"}. The component @{term "φ (S f y) j"} at @{term j}
of this cone is a point of @{term "S.cod (D j)"}. Thus, @{term "f ∈ hom a' a"} determines
a cone @{term χf} with apex @{term a'} whose component at @{term j} is the
unique arrow @{term "χf j"} of @{term[source=true] S} such that
@{term "χf j ∈ hom a' (cod (D j))"} and @{term "S (χf j) y = φ (S f y) j"}
for all points @{term y} of @{term a'}.
The cone @{term χa} corresponding to @{term "a ∈ S.hom a a"} is then a limit cone.
›
assume a: "S.ide a ∧ (∃φ. bij_betw φ (S.hom S.unity a) (cones S.unity))"
hence ide_a: "S.ide a" by auto
show "has_as_limit a"
proof -
from a obtain φ where φ: "bij_betw φ (S.hom S.unity a) (cones S.unity)" by blast
have X: "⋀f j y. ⟦ «f : S.dom f → a»; J.arr j; «y : S.unity → S.dom f» ⟧
⟹ «φ (f ⋅ y) j : S.unity → S.cod (D j)»"
proof -
fix f j y
assume f: "«f : S.dom f → a»" and j: "J.arr j" and y: "«y : S.unity → S.dom f»"
interpret χ: cone J S D S.unity ‹φ (S f y)›
using f y φ bij_betw_imp_funcset funcset_mem by blast
show "«φ (f ⋅ y) j : S.unity → S.cod (D j)»" using j by auto
qed
text‹
We want to define the component @{term "χj ∈ S.hom (S.dom f) (S.cod (D j))"}
at @{term j} of a cone by specifying how it acts by composition on points
@{term "y ∈ S.hom S.unity (S.dom f)"}. We can do this because @{term[source=true] S}
is a set category.
›
let ?P = "λf j χj. «χj : S.dom f → S.cod (D j)» ∧
(∀y. «y : S.unity → S.dom f» ⟶ χj ⋅ y = φ (f ⋅ y) j)"
let ?χ = "λf j. if J.arr j then (THE χj. ?P f j χj) else S.null"
have χ: "⋀f j. ⟦ «f : S.dom f → a»; J.arr j ⟧ ⟹ ?P f j (?χ f j)"
proof -
fix b f j
assume f: "«f : S.dom f → a»" and j: "J.arr j"
interpret B: constant_functor J S ‹S.dom f›
using f by (unfold_locales) auto
have "(λy. φ (f ⋅ y) j) ∈ S.hom S.unity (S.dom f) → S.hom S.unity (S.cod (D j))"
using f j X Pi_I' by simp
hence "∃!χj. ?P f j χj"
using f j S.fun_complete' by (elim S.in_homE) auto
thus "?P f j (?χ f j)" using j theI' [of "?P f j"] by simp
qed
text‹
The arrows @{term "χ f j"} are in fact the components of a cone with apex
@{term "S.dom f"}.
›
have cone: "⋀f. «f : S.dom f → a» ⟹ cone (S.dom f) (?χ f)"
proof -
fix f
assume f: "«f : S.dom f → a»"
interpret B: constant_functor J S ‹S.dom f›
using f by unfold_locales auto
show "cone (S.dom f) (?χ f)"
proof
show "⋀j. ¬J.arr j ⟹ ?χ f j = S.null" by simp
fix j
assume j: "J.arr j"
have 0: "«?χ f j : S.dom f → S.cod (D j)»" using f j χ by simp
show "S.dom (?χ f j) = B.map (J.dom j)" using f j χ by auto
show "S.cod (?χ f j) = D (J.cod j)" using f j χ by auto
have par2: "S.par (?χ f (J.cod j) ⋅ B.map j) (?χ f j)"
using f j 0 χ [of f "J.cod j"] by (elim S.in_homE, auto)
have nat: "⋀y. «y : S.unity → S.dom f» ⟹
(D j ⋅ ?χ f (J.dom j)) ⋅ y = ?χ f j ⋅ y ∧
(?χ f (J.cod j) ⋅ B.map j) ⋅ y = ?χ f j ⋅ y"
proof -
fix y
assume y: "«y : S.unity → S.dom f»"
show "(D j ⋅ ?χ f (J.dom j)) ⋅ y = ?χ f j ⋅ y ∧
(?χ f (J.cod j) ⋅ B.map j) ⋅ y = ?χ f j ⋅ y"
proof
have 1: "φ (f ⋅ y) ∈ cones S.unity"
using f y φ bij_betw_imp_funcset PiE
S.seqI S.cod_comp S.dom_comp mem_Collect_eq
by fastforce
interpret χ: cone J S D S.unity ‹φ (f ⋅ y)›
using 1 by simp
have "(D j ⋅ ?χ f (J.dom j)) ⋅ y = D j ⋅ ?χ f (J.dom j) ⋅ y"
using S.comp_assoc by simp
also have "... = D j ⋅ φ (f ⋅ y) (J.dom j)"
using f y χ χ.is_extensional by simp
also have "... = φ (f ⋅ y) j" using j by auto
also have "... = ?χ f j ⋅ y"
using f j y χ by force
finally show "(D j ⋅ ?χ f (J.dom j)) ⋅ y = ?χ f j ⋅ y" by auto
have "(?χ f (J.cod j) ⋅ B.map j) ⋅ y = ?χ f (J.cod j) ⋅ y"
using j B.map_simp par2 B.value_is_ide S.comp_arr_ide
by (metis (no_types, lifting))
also have "... = φ (f ⋅ y) (J.cod j)"
using f y χ χ.is_extensional by simp
also have "... = φ (f ⋅ y) j"
using j χ.is_natural_2
by (metis J.arr_cod χ.A.map_simp J.cod_cod)
also have "... = ?χ f j ⋅ y"
using f y χ χ.is_extensional by simp
finally show "(?χ f (J.cod j) ⋅ B.map j) ⋅ y = ?χ f j ⋅ y" by auto
qed
qed
show "D j ⋅ ?χ f (J.dom j) = ?χ f j"
proof -
have "S.par (D j ⋅ ?χ f (J.dom j)) (?χ f j)"
using f j 0 χ [of f "J.dom j"] by (elim S.in_homE, auto)
thus ?thesis
using nat 0
apply (intro S.arr_eqI' [of "D j ⋅ ?χ f (J.dom j)" "?χ f j"])
apply force
by auto
qed
show "?χ f (J.cod j) ⋅ B.map j = ?χ f j"
using par2 nat 0 f j χ
apply (intro S.arr_eqI' [of "?χ f (J.cod j) ⋅ B.map j" "?χ f j"])
apply force
by (metis (no_types, lifting) S.in_homE)
qed
qed
interpret χa: cone J S D a ‹?χ a› using a cone [of a] by fastforce
text‹
Finally, show that ‹χ a› is a limit cone.
›
interpret χa: limit_cone J S D a ‹?χ a›
proof
fix a' χ'
assume cone_χ': "cone a' χ'"
interpret χ': cone J S D a' χ' using cone_χ' by auto
show "∃!f. «f : a' → a» ∧ cones_map f (?χ a) = χ'"
proof
let ?ψ = "inv_into (S.hom S.unity a) φ"
have ψ: "?ψ ∈ cones S.unity → S.hom S.unity a"
using φ bij_betw_inv_into bij_betwE by blast
let ?P = "λf. «f : a' → a» ∧
(∀y. y ∈ S.hom S.unity a' ⟶ f ⋅ y = ?ψ (cones_map y χ'))"
have 1: "∃!f. ?P f"
proof -
have "(λy. ?ψ (cones_map y χ')) ∈ S.hom S.unity a' → S.hom S.unity a"
proof
fix x
assume "x ∈ S.hom S.unity a'"
hence "«x : S.unity → a'»" by simp
hence "cones_map x ∈ cones a' → cones S.unity"
using cones_map_mapsto [of x] by (elim S.in_homE) auto
hence "cones_map x χ' ∈ cones S.unity"
using cone_χ' by blast
thus "?ψ (cones_map x χ') ∈ S.hom S.unity a"
using ψ by auto
qed
thus ?thesis
using S.fun_complete' a χ'.ide_apex by simp
qed
let ?f = "THE f. ?P f"
have f: "?P ?f" using 1 theI' [of ?P] by simp
have f_in_hom: "«?f : a' → a»" using f by simp
have f_map: "cones_map ?f (?χ a) = χ'"
proof -
have 1: "cone a' (cones_map ?f (?χ a))"
proof -
have "cones_map ?f ∈ cones a → cones a'"
using f_in_hom cones_map_mapsto [of ?f] by (elim S.in_homE) auto
hence "cones_map ?f (?χ a) ∈ cones a'"
using χa.cone_axioms by blast
thus ?thesis by simp
qed
interpret fχa: cone J S D a' ‹cones_map ?f (?χ a)›
using 1 by simp
show ?thesis
proof
fix j
have "¬J.arr j ⟹ cones_map ?f (?χ a) j = χ' j"
using 1 χ'.is_extensional fχa.is_extensional by presburger
moreover have "J.arr j ⟹ cones_map ?f (?χ a) j = χ' j"
proof -
assume j: "J.arr j"
show "cones_map ?f (?χ a) j = χ' j"
proof (intro S.arr_eqI' [of "cones_map ?f (?χ a) j" "χ' j"])
show par: "S.par (cones_map ?f (?χ a) j) (χ' j)"
using j χ'.preserves_cod χ'.preserves_dom χ'.preserves_reflects_arr
fχa.preserves_cod fχa.preserves_dom fχa.preserves_reflects_arr
by presburger
fix y
assume "«y : S.unity → S.dom (cones_map ?f (?χ a) j)»"
hence y: "«y : S.unity → a'»"
using j fχa.preserves_dom by simp
have 1: "«?χ a j : a → D (J.cod j)»"
using j χa.preserves_hom by force
have 2: "«?f ⋅ y : S.unity → a»"
using f_in_hom y by blast
have "cones_map ?f (?χ a) j ⋅ y = (?χ a j ⋅ ?f) ⋅ y"
proof -
have "S.cod ?f = a" using f_in_hom by blast
thus ?thesis using j χa.cone_axioms by simp
qed
also have "... = ?χ a j ⋅ ?f ⋅ y"
using 1 j y f_in_hom S.comp_assoc S.seqI' by blast
also have "... = φ (a ⋅ ?f ⋅ y) j"
using 1 2 ide_a f j y χ [of a] by (simp add: S.ide_in_hom)
also have "... = φ (?f ⋅ y) j"
using a 2 y S.comp_cod_arr by (elim S.in_homE, auto)
also have "... = φ (?ψ (cones_map y χ')) j"
using j y f by simp
also have "... = cones_map y χ' j"
proof -
have "cones_map y χ' ∈ cones S.unity"
using cone_χ' y cones_map_mapsto by force
hence "φ (?ψ (cones_map y χ')) = cones_map y χ'"
using φ bij_betw_inv_into_right [of φ] by simp
thus ?thesis by auto
qed
also have "... = χ' j ⋅ y"
using cone_χ' j y by auto
finally show "cones_map ?f (?χ a) j ⋅ y = χ' j ⋅ y"
by auto
qed
qed
ultimately show "cones_map ?f (?χ a) j = χ' j" by blast
qed
qed
show "«?f : a' → a» ∧ cones_map ?f (?χ a) = χ'"
using f_in_hom f_map by simp
show "⋀f'. «f' : a' → a» ∧ cones_map f' (?χ a) = χ' ⟹ f' = ?f"
proof -
fix f'
assume f': "«f' : a' → a» ∧ cones_map f' (?χ a) = χ'"
have f'_in_hom: "«f' : a' → a»" using f' by simp
have f'_map: "cones_map f' (?χ a) = χ'" using f' by simp
show "f' = ?f"
proof (intro S.arr_eqI' [of f' ?f])
show "S.par f' ?f"
using f_in_hom f'_in_hom by (elim S.in_homE, auto)
show "⋀y'. «y' : S.unity → S.dom f'» ⟹ f' ⋅ y' = ?f ⋅ y'"
proof -
fix y'
assume y': "«y' : S.unity → S.dom f'»"
have 0: "φ (f' ⋅ y') = cones_map y' χ'"
proof
fix j
have 1: "«f' ⋅ y' : S.unity → a»" using f'_in_hom y' by auto
hence 2: "φ (f' ⋅ y') ∈ cones S.unity"
using φ bij_betw_imp_funcset [of φ "S.hom S.unity a" "cones S.unity"]
by auto
interpret χ'': cone J S D S.unity ‹φ (f' ⋅ y')› using 2 by auto
have "¬J.arr j ⟹ φ (f' ⋅ y') j = cones_map y' χ' j"
using f' y' cone_χ' χ''.is_extensional mem_Collect_eq restrict_apply
by (elim S.in_homE, auto)
moreover have "J.arr j ⟹ φ (f' ⋅ y') j = cones_map y' χ' j"
proof -
assume j: "J.arr j"
have 3: "«?χ a j : a → D (J.cod j)»"
using j χa.preserves_hom by force
have "φ (f' ⋅ y') j = φ (a ⋅ f' ⋅ y') j"
using a f' y' j S.comp_cod_arr by (elim S.in_homE, auto)
also have "... = ?χ a j ⋅ f' ⋅ y'"
using 1 3 χ [of a] a f' y' j by fastforce
also have "... = (?χ a j ⋅ f') ⋅ y'"
using S.comp_assoc by simp
also have "... = cones_map f' (?χ a) j ⋅ y'"
using f' y' j χa.cone_axioms by auto
also have "... = χ' j ⋅ y'"
using f' by blast
also have "... = cones_map y' χ' j"
using y' j cone_χ' f' mem_Collect_eq restrict_apply by force
finally show "φ (f' ⋅ y') j = cones_map y' χ' j" by auto
qed
ultimately show "φ (f' ⋅ y') j = cones_map y' χ' j" by auto
qed
hence "f' ⋅ y' = ?ψ (cones_map y' χ')"
using φ f'_in_hom y' S.comp_in_homI
bij_betw_inv_into_left [of φ "S.hom S.unity a" "cones S.unity" "f' ⋅ y'"]
by (elim S.in_homE, auto)
moreover have "?f ⋅ y' = ?ψ (cones_map y' χ')"
using φ 0 1 f f_in_hom f'_in_hom y' S.comp_in_homI
bij_betw_inv_into_left [of φ "S.hom S.unity a" "cones S.unity" "?f ⋅ y'"]
by (elim S.in_homE, auto)
ultimately show "f' ⋅ y' = ?f ⋅ y'" by auto
qed
qed
qed
qed
qed
have "limit_cone a (?χ a)" ..
thus ?thesis by auto
qed
qed
end
locale diagram_in_replete_set_category =
J: category J +
S: replete_set_category S +
diagram J S D
for J :: "'j comp" (infixr "⋅⇩J" 55)
and S :: "'s comp" (infixr "⋅" 55)
and D :: "'j ⇒ 's"
begin
sublocale diagram_in_set_category J S ‹cardSuc (cmax (card_of (UNIV :: 's set)) natLeq)› D
..
end
context set_category
begin
text‹
A set category has an equalizer for any parallel pair of arrows.
›
lemma has_equalizers:
shows "has_equalizers"
proof (unfold has_equalizers_def)
have "⋀f0 f1. par f0 f1 ⟹ ∃e. has_as_equalizer f0 f1 e"
proof -
fix f0 f1
assume par: "par f0 f1"
interpret J: parallel_pair .
interpret PP: parallel_pair_diagram S f0 f1
apply unfold_locales using par by auto
interpret PP: diagram_in_set_category J.comp S 𝔄 PP.map ..
text‹
Let @{term a} be the object corresponding to the set of all images of equalizing points
of @{term "dom f0"}, and let @{term e} be the inclusion of @{term a} in @{term "dom f0"}.
›
let ?a = "mkIde (img ` {e. e ∈ hom unity (dom f0) ∧ f0 ⋅ e = f1 ⋅ e})"
have 0: "{e. e ∈ hom unity (dom f0) ∧ f0 ⋅ e = f1 ⋅ e} ⊆ hom unity (dom f0)"
by auto
hence 1: "img ` {e. e ∈ hom unity (dom f0) ∧ f0 ⋅ e = f1 ⋅ e} ⊆ Univ"
using img_point_in_Univ by auto
have 2: "|img ` {e. e ∈ hom unity (dom f0) ∧ f0 ⋅ e = f1 ⋅ e}| <o 𝔄"
proof -
have "|hom unity (dom f0)| =o |Dom f0|"
using par bij_betw_points_and_set [of "dom f0"]
by (simp add: card_of_ordIsoI)
moreover have "|Dom f0| <o 𝔄"
using par set_card by simp
ultimately have "|hom unity (dom f0)| <o 𝔄"
using ordIso_ordLess_trans by blast
moreover have
"|{e. e ∈ hom unity (dom f0) ∧ f0 ⋅ e = f1 ⋅ e}| ≤o |hom unity (dom f0)|"
using 0 by simp
ultimately have "|{e. e ∈ hom unity (dom f0) ∧ f0 ⋅ e = f1 ⋅ e}| <o 𝔄"
using ordLeq_ordLess_trans by blast
thus ?thesis
using card_of_image ordLeq_ordLess_trans by blast
qed
have ide_a: "ide ?a" using 1 2 ide_mkIde by auto
have set_a: "set ?a = img ` {e. e ∈ hom unity (dom f0) ∧ f0 ⋅ e = f1 ⋅ e}"
using 1 2 set_mkIde by simp
have incl_in_a: "incl_in ?a (dom f0)"
proof -
have "ide (dom f0)"
using PP.is_parallel by simp
moreover have "set ?a ⊆ set (dom f0)"
proof -
have "set ?a = img ` {e. e ∈ hom unity (dom f0) ∧ f0 ⋅ e = f1 ⋅ e}"
using img_point_in_Univ set_a by blast
thus ?thesis
using imageE img_point_elem_set mem_Collect_eq subsetI by auto
qed
ultimately show ?thesis
using incl_in_def ‹ide ?a› by simp
qed
text‹
Then @{term "set a"} is in bijective correspondence with @{term "PP.cones unity"}.
›
let ?φ = "λt. PP.mkCone (mkPoint (dom f0) t)"
let ?ψ = "λχ. img (χ (J.Zero))"
have bij: "bij_betw ?φ (set ?a) (PP.cones unity)"
proof (intro bij_betwI)
show "?φ ∈ set ?a → PP.cones unity"
proof
fix t
assume t: "t ∈ set ?a"
hence 1: "t ∈ img ` {e. e ∈ hom unity (dom f0) ∧ f0 ⋅ e = f1 ⋅ e}"
using set_a by blast
then have 2: "mkPoint (dom f0) t ∈ hom unity (dom f0)"
using mkPoint_in_hom imageE mem_Collect_eq mkPoint_img(2) by auto
with 1 have 3: "mkPoint (dom f0) t ∈ {e. e ∈ hom unity (dom f0) ∧ f0 ⋅ e = f1 ⋅ e}"
using mkPoint_img(2) by auto
then have "PP.is_equalized_by (mkPoint (dom f0) t)"
using CollectD par by fastforce
thus "PP.mkCone (mkPoint (dom f0) t) ∈ PP.cones unity"
using 2 PP.cone_mkCone [of "mkPoint (dom f0) t"] by auto
qed
show "?ψ ∈ PP.cones unity → set ?a"
proof
fix χ
assume χ: "χ ∈ PP.cones unity"
interpret χ: cone J.comp S PP.map unity χ using χ by auto
have "χ (J.Zero) ∈ hom unity (dom f0) ∧ f0 ⋅ χ (J.Zero) = f1 ⋅ χ (J.Zero)"
using χ PP.map_def PP.is_equalized_by_cone J.arr_char by auto
hence "img (χ (J.Zero)) ∈ set ?a"
using set_a by simp
thus "?ψ χ ∈ set ?a" by blast
qed
show "⋀t. t ∈ set ?a ⟹ ?ψ (?φ t) = t"
using set_a J.arr_char PP.mkCone_def imageE mem_Collect_eq mkPoint_img(2)
by auto
show "⋀χ. χ ∈ PP.cones unity ⟹ ?φ (?ψ χ) = χ"
proof -
fix χ
assume χ: "χ ∈ PP.cones unity"
interpret χ: cone J.comp S PP.map unity χ using χ by auto
have 1: "χ (J.Zero) ∈ hom unity (dom f0) ∧ f0 ⋅ χ (J.Zero) = f1 ⋅ χ (J.Zero)"
using χ PP.map_def PP.is_equalized_by_cone J.arr_char by auto
hence "img (χ (J.Zero)) ∈ set ?a"
using set_a by simp
hence "img (χ (J.Zero)) ∈ set (dom f0)"
using incl_in_a incl_in_def by auto
hence "mkPoint (dom f0) (img (χ J.Zero)) = χ J.Zero"
using 1 mkPoint_img(2) by blast
hence "?φ (?ψ χ) = PP.mkCone (χ J.Zero)" by simp
also have "... = χ"
using χ PP.mkCone_cone by simp
finally show "?φ (?ψ χ) = χ" by auto
qed
qed
text‹
It follows that @{term a} is a limit of ‹PP›, and that the limit cone gives an
equalizer of @{term f0} and @{term f1}.
›
have "∃μ. bij_betw μ (hom unity ?a) (set ?a)"
using bij_betw_points_and_set ide_a by auto
from this obtain μ where μ: "bij_betw μ (hom unity ?a) (set ?a)" by blast
have "bij_betw (?φ o μ) (hom unity ?a) (PP.cones unity)"
using bij μ bij_betw_comp_iff by blast
hence "∃φ. bij_betw φ (hom unity ?a) (PP.cones unity)" by auto
hence "PP.has_as_limit ?a"
using ide_a PP.limits_are_sets_of_cones by simp
from this obtain ε where ε: "limit_cone J.comp S PP.map ?a ε" by auto
interpret ε: limit_cone J.comp S PP.map ?a ε using ε by auto
have "PP.mkCone (ε (J.Zero)) = ε"
using ε PP.mkCone_cone ε.cone_axioms by simp
moreover have "dom (ε (J.Zero)) = ?a"
using J.ide_char ε.preserves_hom ε.A.map_def by simp
ultimately have "PP.has_as_equalizer (ε J.Zero)"
using ε by simp
thus "∃e. has_as_equalizer f0 f1 e"
using par has_as_equalizer_def by auto
qed
thus "∀f0 f1. par f0 f1 ⟶ (∃e. has_as_equalizer f0 f1 e)" by auto
qed
end
sublocale set_category ⊆ category_with_equalizers S
apply unfold_locales using has_equalizers by auto
context set_category
begin
text‹
The aim of the next results is to characterize the conditions under which a set
category has products. In a traditional development of category theory,
one shows that the category \textbf{Set} of \emph{all} sets has all small
(\emph{i.e.}~set-indexed) products. In the present context we do not have a
category of \emph{all} sets, but rather only a category of all sets with
elements at a particular type. Clearly, we cannot expect such a category
to have products indexed by arbitrarily large sets. The existence of
@{term I}-indexed products in a set category @{term[source=true] S} implies that the universe
‹S.Univ› of @{term[source=true] S} must be large enough to admit the formation of
@{term I}-tuples of its elements. Conversely, for a set category @{term[source=true] S}
the ability to form @{term I}-tuples in @{term Univ} implies that
@{term[source=true] S} has @{term I}-indexed products. Below we make this precise by
defining the notion of when a set category @{term[source=true] S}
``admits @{term I}-indexed tupling'' and we show that @{term[source=true] S}
has @{term I}-indexed products if and only if it admits @{term I}-indexed tupling.
The definition of ``@{term[source=true] S} admits @{term I}-indexed tupling'' says that
there is an injective map, from the space of extensional functions from
@{term I} to @{term Univ}, to @{term Univ}. However for a convenient
statement and proof of the desired result, the definition of extensional
function from theory @{theory "HOL-Library.FuncSet"} needs to be modified.
The theory @{theory "HOL-Library.FuncSet"} uses the definite, but arbitrarily chosen value
@{term undefined} as the value to be assumed by an extensional function outside
of its domain. In the context of the ‹set_category›, though, it is
more natural to use ‹S.unity›, which is guaranteed to be an element of the
universe of @{term[source=true] S}, for this purpose. Doing things that way makes it
simpler to establish a bijective correspondence between cones over @{term D} with apex
@{term unity} and the set of extensional functions @{term d} that map
each arrow @{term j} of @{term J} to an element @{term "d j"} of @{term "set (D j)"}.
Possibly it makes sense to go back and make this change in ‹set_category›,
but that would mean completely abandoning @{theory "HOL-Library.FuncSet"} and essentially
introducing a duplicate version for use with ‹set_category›.
As a compromise, what I have done here is to locally redefine the few notions from
@{theory "HOL-Library.FuncSet"} that I need in order to prove the next set of results.
The redefined notions are primed to avoid confusion with the original versions.
›
definition extensional'
where "extensional' A ≡ {f. ∀x. x ∉ A ⟶ f x = unity}"
abbreviation PiE'
where "PiE' A B ≡ Pi A B ∩ extensional' A"
abbreviation restrict'
where "restrict' f A ≡ λx. if x ∈ A then f x else unity"
lemma extensional'I [intro]:
assumes "⋀x. x ∉ A ⟹ f x = unity"
shows "f ∈ extensional' A"
using assms extensional'_def by auto
lemma extensional'_arb:
assumes "f ∈ extensional' A" and "x ∉ A"
shows "f x = unity"
using assms extensional'_def by fast
lemma extensional'_monotone:
assumes "A ⊆ B"
shows "extensional' A ⊆ extensional' B"
proof
fix f
assume f: "f ∈ extensional' A"
have 1: "∀x. x ∉ A ⟶ f x = unity" using f extensional'_def by fast
hence "∀x. x ∉ B ⟶ f x = unity" using assms by auto
thus "f ∈ extensional' B" using extensional'_def by blast
qed
lemma PiE'_mono: "(⋀x. x ∈ A ⟹ B x ⊆ C x) ⟹ PiE' A B ⊆ PiE' A C"
by auto
end
locale discrete_diagram_in_replete_set_category =
S: replete_set_category S +
discrete_diagram J S D +
diagram_in_replete_set_category J S D
for J :: "'j comp" (infixr "⋅⇩J" 55)
and S :: "'s comp" (infixr "⋅" 55)
and D :: "'j ⇒ 's"
begin
text‹
For @{term D} a discrete diagram in a set category, there is a bijective correspondence
between cones over @{term D} with apex unity and the set of extensional functions @{term d}
that map each arrow @{term j} of @{term[source=true] J} to an element of
@{term "S.set (D j)"}.
›
abbreviation I
where "I ≡ Collect J.arr"
definition funToCone
where "funToCone F ≡ λj. if J.arr j then S.mkPoint (D j) (F j) else S.null"
definition coneToFun
where "coneToFun χ ≡ λj. if J.arr j then S.img (χ j) else S.unity"
lemma funToCone_mapsto:
shows "funToCone ∈ S.PiE' I (S.set o D) → cones S.unity"
proof
fix F
assume F: "F ∈ S.PiE' I (S.set o D)"
interpret U: constant_functor J S S.unity
apply unfold_locales using S.ide_unity by auto
have 1: "S.ide (S.mkIde S.Univ)"
using S.ide_mkIde by simp
have "cone S.unity (funToCone F)"
proof
show "⋀j. ¬J.arr j ⟹ funToCone F j = S.null"
using funToCone_def by simp
fix j
assume j: "J.arr j"
have "funToCone F j = S.mkPoint (D j) (F j)"
using j funToCone_def by simp
moreover have "... ∈ S.hom S.unity (D j)"
using F j is_discrete S.img_mkPoint(1) [of "D j"] by force
ultimately have 2: "funToCone F j ∈ S.hom S.unity (D j)" by auto
show 3: "S.dom (funToCone F j) = U.map (J.dom j)"
using 2 j U.map_simp by auto
show 4: "S.cod (funToCone F j) = D (J.cod j)"
using 2 j is_discrete by auto
show "D j ⋅ funToCone F (J.dom j) = funToCone F j"
using 2 j is_discrete S.comp_cod_arr by auto
show "funToCone F (J.cod j) ⋅ (U.map j) = funToCone F j"
using 3 j is_discrete U.map_simp S.arr_dom_iff_arr S.comp_arr_dom U.preserves_arr
by (metis J.ide_char)
qed
thus "funToCone F ∈ cones S.unity" by auto
qed
lemma coneToFun_mapsto:
shows "coneToFun ∈ cones S.unity → S.PiE' I (S.set o D)"
proof
fix χ
assume χ: "χ ∈ cones S.unity"
interpret χ: cone J S D S.unity χ using χ by auto
show "coneToFun χ ∈ S.PiE' I (S.set o D)"
proof
show "coneToFun χ ∈ Pi I (S.set o D)"
using S.mkPoint_img(1) coneToFun_def is_discrete χ.component_in_hom
by (simp add: S.img_point_elem_set restrict_apply')
show "coneToFun χ ∈ S.extensional' I"
proof
fix x
show "x ∉ I ⟹ coneToFun χ x = S.unity"
using coneToFun_def by simp
qed
qed
qed
lemma funToCone_coneToFun:
assumes "χ ∈ cones S.unity"
shows "funToCone (coneToFun χ) = χ"
proof
interpret χ: cone J S D S.unity χ using assms by auto
fix j
have "¬J.arr j ⟹ funToCone (coneToFun χ) j = χ j"
using funToCone_def χ.is_extensional by simp
moreover have "J.arr j ⟹ funToCone (coneToFun χ) j = χ j"
using funToCone_def coneToFun_def S.mkPoint_img(2) is_discrete χ.component_in_hom
by auto
ultimately show "funToCone (coneToFun χ) j = χ j" by blast
qed
lemma coneToFun_funToCone:
assumes "F ∈ S.PiE' I (S.set o D)"
shows "coneToFun (funToCone F) = F"
proof
fix i
have "i ∉ I ⟹ coneToFun (funToCone F) i = F i"
using assms coneToFun_def S.extensional'_arb [of F I i] by auto
moreover have "i ∈ I ⟹ coneToFun (funToCone F) i = F i"
proof -
assume i: "i ∈ I"
have "coneToFun (funToCone F) i = S.img (funToCone F i)"
using i coneToFun_def by simp
also have "... = S.img (S.mkPoint (D i) (F i))"
using i funToCone_def by auto
also have "... = F i"
using assms i is_discrete S.img_mkPoint(2) by force
finally show "coneToFun (funToCone F) i = F i" by auto
qed
ultimately show "coneToFun (funToCone F) i = F i" by auto
qed
lemma bij_coneToFun:
shows "bij_betw coneToFun (cones S.unity) (S.PiE' I (S.set o D))"
using coneToFun_mapsto funToCone_mapsto funToCone_coneToFun coneToFun_funToCone
bij_betwI
by blast
lemma bij_funToCone:
shows "bij_betw funToCone (S.PiE' I (S.set o D)) (cones S.unity)"
using coneToFun_mapsto funToCone_mapsto funToCone_coneToFun coneToFun_funToCone
bij_betwI
by blast
end
context replete_set_category
begin
text‹
A set category admits @{term I}-indexed tupling if there is an injective map that takes
each extensional function from @{term I} to @{term Univ} to an element of @{term Univ}.
›
definition admits_tupling
where "admits_tupling I ≡ ∃π. π ∈ PiE' I (λ_. Univ) → Univ ∧ inj_on π (PiE' I (λ_. Univ))"
lemma admits_tupling_monotone:
assumes "admits_tupling I" and "I' ⊆ I"
shows "admits_tupling I'"
proof -
from assms(1) obtain π
where π: "π ∈ PiE' I (λ_. Univ) → Univ ∧ inj_on π (PiE' I (λ_. Univ))"
using admits_tupling_def by metis
have "π ∈ PiE' I' (λ_. Univ) → Univ"
proof
fix f
assume f: "f ∈ PiE' I' (λ_. Univ)"
have "f ∈ PiE' I (λ_. Univ)"
using assms(2) f extensional'_def [of I'] terminal_unity extensional'_monotone by auto
thus "π f ∈ Univ" using π by auto
qed
moreover have "inj_on π (PiE' I' (λ_. Univ))"
proof -
have 1: "⋀F A A'. inj_on F A ∧ A' ⊆ A ⟹ inj_on F A'"
using subset_inj_on by blast
moreover have "PiE' I' (λ_. Univ) ⊆ PiE' I (λ_. Univ)"
using assms(2) extensional'_def [of I'] terminal_unity by auto
ultimately show ?thesis using π assms(2) by blast
qed
ultimately show ?thesis using admits_tupling_def by metis
qed
lemma has_products_iff_admits_tupling:
fixes I :: "'i set"
shows "has_products I ⟷ I ≠ UNIV ∧ admits_tupling I"
proof
text‹
If @{term[source=true] S} has @{term I}-indexed products, then for every @{term I}-indexed
discrete diagram @{term D} in @{term[source=true] S} there is an object @{term ΠD}
of @{term[source=true] S} whose points are in bijective correspondence with the set of
cones over @{term D} with apex @{term unity}. In particular this is true for
the diagram @{term D} that assigns to each element of @{term I} the
``universal object'' @{term "mkIde Univ"}.
›
assume has_products: "has_products I"
have I: "I ≠ UNIV" using has_products has_products_def by auto
interpret J: discrete_category I ‹SOME x. x ∉ I›
using I someI_ex [of "λx. x ∉ I"] by (unfold_locales, auto)
let ?D = "λi. mkIde Univ"
interpret D: discrete_diagram_from_map I S ?D ‹SOME j. j ∉ I›
using J.not_arr_null J.arr_char ide_mkIde
by (unfold_locales, auto)
interpret D: discrete_diagram_in_replete_set_category J.comp S D.map ..
have "discrete_diagram J.comp S D.map" ..
from this obtain ΠD χ where χ: "product_cone J.comp S D.map ΠD χ"
using has_products has_products_def [of I] ex_productE [of "J.comp" D.map]
D.diagram_axioms
by blast
interpret χ: product_cone J.comp S D.map ΠD χ
using χ by auto
have "D.has_as_limit ΠD"
using χ.limit_cone_axioms by auto
hence ΠD: "ide ΠD ∧ (∃φ. bij_betw φ (hom unity ΠD) (D.cones unity))"
using D.limits_are_sets_of_cones by simp
from this obtain φ where φ: "bij_betw φ (hom unity ΠD) (D.cones unity)"
by blast
have φ': "inv_into (hom unity ΠD) φ ∈ D.cones unity → hom unity ΠD ∧
inj_on (inv_into (hom unity ΠD) φ) (D.cones unity)"
using φ bij_betw_inv_into bij_betw_imp_inj_on bij_betw_imp_funcset by blast
let ?π = "img o (inv_into (hom unity ΠD) φ) o D.funToCone"
have 1: "D.funToCone ∈ PiE' I (set o D.map) → D.cones unity"
using D.funToCone_mapsto extensional'_def [of I] by auto
have 2: "inv_into (hom unity ΠD) φ ∈ D.cones unity → hom unity ΠD"
using φ' by auto
have 3: "img ∈ hom unity ΠD → Univ"
using img_point_in_Univ by blast
have 4: "inj_on D.funToCone (PiE' I (set o D.map))"
proof -
have "D.I = I" by auto
thus ?thesis
using D.bij_funToCone bij_betw_imp_inj_on by auto
qed
have 5: "inj_on (inv_into (hom unity ΠD) φ) (D.cones unity)"
using φ' by auto
have 6: "inj_on img (hom unity ΠD)"
using ΠD bij_betw_points_and_set bij_betw_imp_inj_on [of img "hom unity ΠD" "set ΠD"]
by simp
have "?π ∈ PiE' I (set o D.map) → Univ"
using 1 2 3 by force
moreover have "inj_on ?π (PiE' I (set o D.map))"
proof -
have 7: "⋀A B C D F G H. F ∈ A → B ∧ G ∈ B → C ∧ H ∈ C → D
∧ inj_on F A ∧ inj_on G B ∧ inj_on H C
⟹ inj_on (H o G o F) A"
proof (intro inj_onI)
fix A :: "'a set" and B :: "'b set" and C :: "'c set" and D :: "'d set"
and F :: "'a ⇒ 'b" and G :: "'b ⇒ 'c" and H :: "'c ⇒ 'd"
assume a1: "F ∈ A → B ∧ G ∈ B → C ∧ H ∈ C → D ∧
inj_on F A ∧ inj_on G B ∧ inj_on H C"
fix a a'
assume a: "a ∈ A" and a': "a' ∈ A" and eq: "(H o G o F) a = (H o G o F) a'"
have "H (G (F a)) = H (G (F a'))" using eq by simp
moreover have "G (F a) ∈ C ∧ G (F a') ∈ C" using a a' a1 by auto
ultimately have "G (F a) = G (F a')" using a1 inj_onD by metis
moreover have "F a ∈ B ∧ F a' ∈ B" using a a' a1 by auto
ultimately have "F a = F a'" using a1 inj_onD by metis
thus "a = a'" using a a' a1 inj_onD by metis
qed
show ?thesis
using 1 2 3 4 5 6 7 [of D.funToCone "PiE' I (set o D.map)" "D.cones unity"
"inv_into (hom unity ΠD) φ" "hom unity ΠD"
img Univ]
by fastforce
qed
moreover have "PiE' I (set o D.map) = PiE' I (λx. Univ)"
proof -
have "⋀i. i ∈ I ⟹ (set o D.map) i = Univ"
using J.arr_char D.map_def set_mkIde by simp
thus ?thesis by blast
qed
ultimately have "?π ∈ (PiE' I (λx. Univ)) → Univ ∧ inj_on ?π (PiE' I (λx. Univ))"
by auto
thus "I ≠ UNIV ∧ admits_tupling I"
using I admits_tupling_def by auto
next
assume ex_π: "I ≠ UNIV ∧ admits_tupling I"
show "has_products I"
proof (unfold has_products_def)
from ex_π obtain π
where π: "π ∈ (PiE' I (λx. Univ)) → Univ ∧ inj_on π (PiE' I (λx. Univ))"
using admits_tupling_def by metis
text‹
Given an @{term I}-indexed discrete diagram @{term D}, obtain the object @{term ΠD}
of @{term[source=true] S} corresponding to the set @{term "π ` PiE I D"} of all
@{term "π d"} where ‹d ∈ d ∈ J →⇩E Univ› and @{term "d i ∈ D i"}
for all @{term "i ∈ I"}.
The elements of @{term ΠD} are in bijective correspondence with the set of cones
over @{term D}, hence @{term ΠD} is a limit of @{term D}.
›
have "⋀J D. discrete_diagram J S D ∧ Collect (partial_magma.arr J) = I
⟹ ∃ΠD. has_as_product J D ΠD"
proof
fix J :: "'i comp" and D
assume D: "discrete_diagram J S D ∧ Collect (partial_magma.arr J) = I"
interpret J: category J
using D discrete_diagram.axioms(1) by blast
interpret D: discrete_diagram J S D
using D by simp
interpret D: discrete_diagram_in_replete_set_category J S D ..
let ?ΠD = "mkIde (π ` PiE' I (set o D))"
have 0: "ide ?ΠD"
proof -
have "set o D ∈ I → Pow Univ"
using Pow_iff incl_in_def o_apply elem_set_implies_incl_in
set_subset_Univ subsetI
by (metis (mono_tags, lifting) Pi_I')
hence "π ` PiE' I (set o D) ⊆ Univ"
using π by blast
thus ?thesis using π ide_mkIde by simp
qed
hence set_ΠD: "π ` PiE' I (set o D) = set ?ΠD"
using 0 ide_in_hom arr_mkIde set_mkIde by auto
text‹
The elements of @{term ΠD} are all values of the form @{term "π d"},
where @{term d} satisfies @{term "d i ∈ set (D i)"} for all @{term "i ∈ I"}.
Such @{term d} correspond bijectively to cones.
Since @{term π} is injective, the values @{term "π d"} correspond bijectively to cones.
›
let ?φ = "mkPoint ?ΠD o π o D.coneToFun"
let ?φ' = "D.funToCone o inv_into (PiE' I (set o D)) π o img"
have 1: "π ∈ PiE' I (set o D) → set ?ΠD ∧ inj_on π (PiE' I (set o D))"
proof -
have "PiE' I (set o D) ⊆ PiE' I (λx. Univ)"
using set_subset_Univ elem_set_implies_incl_in elem_set_implies_set_eq_singleton
incl_in_def PiE'_mono
by (metis comp_apply subsetI)
thus ?thesis using π subset_inj_on set_ΠD Pi_I' imageI by fastforce
qed
have 2: "inv_into (PiE' I (set o D)) π ∈ set ?ΠD → PiE' I (set o D)"
proof
fix y
assume y: "y ∈ set ?ΠD"
have "y ∈ π ` (PiE' I (set o D))" using y set_ΠD by auto
thus "inv_into (PiE' I (set o D)) π y ∈ PiE' I (set o D)"
using inv_into_into [of y π "PiE' I (set o D)"] by simp
qed
have 3: "⋀x. x ∈ set ?ΠD ⟹ π (inv_into (PiE' I (set o D)) π x) = x"
using set_ΠD by (simp add: f_inv_into_f)
have 4: "⋀d. d ∈ PiE' I (set o D) ⟹ inv_into (PiE' I (set o D)) π (π d) = d"
using 1 by auto
have 5: "D.I = I"
using D by auto
have "bij_betw ?φ (D.cones unity) (hom unity ?ΠD)"
proof (intro bij_betwI)
show "?φ ∈ D.cones unity → hom unity ?ΠD"
proof
fix χ
assume χ: "χ ∈ D.cones unity"
show "?φ χ ∈ hom unity ?ΠD"
using χ 0 1 5 D.coneToFun_mapsto mkPoint_in_hom [of ?ΠD]
by (simp, blast)
qed
show "?φ' ∈ hom unity ?ΠD → D.cones unity"
proof
fix x
assume x: "x ∈ hom unity ?ΠD"
hence "img x ∈ set ?ΠD"
using img_point_elem_set by blast
hence "inv_into (PiE' I (set o D)) π (img x) ∈ Pi I (set ∘ D) ∩ extensional' I"
using 2 by blast
thus "?φ' x ∈ D.cones unity"
using 5 D.funToCone_mapsto by auto
qed
show "⋀x. x ∈ hom unity ?ΠD ⟹ ?φ (?φ' x) = x"
proof -
fix x
assume x: "x ∈ hom unity ?ΠD"
show "?φ (?φ' x) = x"
proof -
have "D.coneToFun (D.funToCone (inv_into (PiE' I (set o D)) π (img x)))
= inv_into (PiE' I (set o D)) π (img x)"
using x 1 5 img_point_elem_set set_ΠD D.coneToFun_funToCone by force
hence "π (D.coneToFun (D.funToCone (inv_into (PiE' I (set o D)) π (img x))))
= img x"
using x 3 img_point_elem_set set_ΠD by force
thus ?thesis using x 0 mkPoint_img by auto
qed
qed
show "⋀χ. χ ∈ D.cones unity ⟹ ?φ' (?φ χ) = χ"
proof -
fix χ
assume χ: "χ ∈ D.cones unity"
show "?φ' (?φ χ) = χ"
proof -
have "img (mkPoint ?ΠD (π (D.coneToFun χ))) = π (D.coneToFun χ)"
using χ 0 1 5 D.coneToFun_mapsto img_mkPoint(2) by blast
hence "inv_into (PiE' I (set o D)) π (img (mkPoint ?ΠD (π (D.coneToFun χ))))
= D.coneToFun χ"
using χ D.coneToFun_mapsto 4 5 by (metis PiE)
hence "D.funToCone (inv_into (PiE' I (set o D)) π
(img (mkPoint ?ΠD (π (D.coneToFun χ)))))
= χ"
using χ D.funToCone_coneToFun by auto
thus ?thesis by auto
qed
qed
qed
hence "bij_betw (inv_into (D.cones unity) ?φ) (hom unity ?ΠD) (D.cones unity)"
using bij_betw_inv_into by blast
hence "∃φ. bij_betw φ (hom unity ?ΠD) (D.cones unity)" by blast
hence "D.has_as_limit ?ΠD"
using ‹ide ?ΠD› D.limits_are_sets_of_cones by simp
from this obtain χ where χ: "limit_cone J S D ?ΠD χ" by blast
interpret χ: limit_cone J S D ?ΠD χ using χ by auto
interpret P: product_cone J S D ?ΠD χ
using χ D.product_coneI by blast
have "product_cone J S D ?ΠD χ" ..
thus "has_as_product J D ?ΠD"
using has_as_product_def by auto
qed
thus "I ≠ UNIV ∧
(∀J D. discrete_diagram J S D ∧ Collect (partial_magma.arr J) = I
⟶ (∃ΠD. has_as_product J D ΠD))"
using ex_π by blast
qed
qed
text‹
Characterization of the completeness properties enjoyed by a set category:
A set category @{term[source=true] S} has all limits at a type @{typ 'j},
if and only if @{term[source=true] S} admits @{term I}-indexed tupling
for all @{typ 'j}-sets @{term I} such that @{term "I ≠ UNIV"}.
›
theorem has_limits_iff_admits_tupling:
shows "has_limits (undefined :: 'j) ⟷ (∀I :: 'j set. I ≠ UNIV ⟶ admits_tupling I)"
proof
assume has_limits: "has_limits (undefined :: 'j)"
show "∀I :: 'j set. I ≠ UNIV ⟶ admits_tupling I"
using has_limits has_products_if_has_limits has_products_iff_admits_tupling by blast
next
assume admits_tupling: "∀I :: 'j set. I ≠ UNIV ⟶ admits_tupling I"
show "has_limits (undefined :: 'j)"
proof -
have 1: "⋀I :: 'j set. I ≠ UNIV ⟹ has_products I"
using admits_tupling has_products_iff_admits_tupling by auto
have "⋀J :: 'j comp. category J ⟹ has_products (Collect (partial_magma.arr J))"
proof -
fix J :: "'j comp"
assume J: "category J"
interpret J: category J using J by auto
have "Collect J.arr ≠ UNIV" using J.not_arr_null by blast
thus "has_products (Collect J.arr)"
using 1 by simp
qed
hence "⋀J :: 'j comp. category J ⟹ has_limits_of_shape J"
proof -
fix J :: "'j comp"
assume J: "category J"
interpret J: category J using J by auto
show "has_limits_of_shape J"
proof -
have "Collect J.arr ≠ UNIV" using J.not_arr_null by fast
moreover have "Collect J.ide ≠ UNIV" using J.not_arr_null by blast
ultimately show ?thesis
using 1 has_limits_if_has_products J.category_axioms by metis
qed
qed
thus "has_limits (undefined :: 'j)"
using has_limits_def by metis
qed
qed
end
section "Limits in Functor Categories"
text‹
In this section, we consider the special case of limits in functor categories,
with the objective of showing that limits in a functor category ‹[A, B]›
are given pointwise, and that ‹[A, B]› has all limits that @{term B} has.
›
locale parametrized_diagram =
J: category J +
A: category A +
B: category B +
JxA: product_category J A +
binary_functor J A B D
for J :: "'j comp" (infixr "⋅⇩J" 55)
and A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and D :: "'j * 'a ⇒ 'b"
begin
notation J.in_hom ("«_ : _ →⇩J _»")
notation JxA.comp (infixr "⋅⇩J⇩x⇩A" 55)
notation JxA.in_hom ("«_ : _ →⇩J⇩x⇩A _»")
text‹
A choice of limit cone for each diagram ‹D (-, a)›, where @{term a}
is an object of @{term[source=true] A}, extends to a functor ‹L: A → B›,
where the action of @{term L} on arrows of @{term[source=true] A} is determined by
universality.
›
abbreviation L
where "L ≡ λl χ. λa. if A.arr a then
limit_cone.induced_arrow J B (λj. D (j, A.cod a))
(l (A.cod a)) (χ (A.cod a))
(l (A.dom a)) (vertical_composite.map J B
(χ (A.dom a)) (λj. D (j, a)))
else B.null"
abbreviation P
where "P ≡ λl χ. λa f. «f : l (A.dom a) →⇩B l (A.cod a)» ∧
diagram.cones_map J B (λj. D (j, A.cod a)) f (χ (A.cod a)) =
vertical_composite.map J B (χ (A.dom a)) (λj. D (j, a))"
lemma L_arr:
assumes "∀a. A.ide a ⟶ limit_cone J B (λj. D (j, a)) (l a) (χ a)"
shows "⋀a. A.arr a ⟹ (∃!f. P l χ a f) ∧ P l χ a (L l χ a)"
proof
fix a
assume a: "A.arr a"
interpret χ_dom_a: limit_cone J B ‹λj. D (j, A.dom a)› ‹l (A.dom a)› ‹χ (A.dom a)›
using a assms by auto
interpret χ_cod_a: limit_cone J B ‹λj. D (j, A.cod a)› ‹l (A.cod a)› ‹χ (A.cod a)›
using a assms by auto
interpret Da: natural_transformation J B ‹λj. D (j, A.dom a)› ‹λj. D (j, A.cod a)›
‹λj. D (j, a)›
using a fixing_arr_gives_natural_transformation_2 by simp
interpret Daoχ_dom_a: vertical_composite J B
χ_dom_a.A.map ‹λj. D (j, A.dom a)› ‹λj. D (j, A.cod a)›
‹χ (A.dom a)› ‹λj. D (j, a)› ..
interpret Daoχ_dom_a: cone J B ‹λj. D (j, A.cod a)› ‹l (A.dom a)› Daoχ_dom_a.map ..
show "P l χ a (L l χ a)"
using a Daoχ_dom_a.cone_axioms χ_cod_a.induced_arrowI [of Daoχ_dom_a.map "l (A.dom a)"]
by auto
show "∃!f. P l χ a f"
using χ_cod_a.is_universal Daoχ_dom_a.cone_axioms by blast
qed
lemma L_ide:
assumes "∀a. A.ide a ⟶ limit_cone J B (λj. D (j, a)) (l a) (χ a)"
shows "⋀a. A.ide a ⟹ L l χ a = l a"
proof -
let ?L = "L l χ"
let ?P = "P l χ"
fix a
assume a: "A.ide a"
interpret χa: limit_cone J B ‹λj. D (j, a)› ‹l a› ‹χ a› using a assms by auto
have Pa: "?P a = (λf. f ∈ B.hom (l a) (l a) ∧
diagram.cones_map J B (λj. D (j, a)) f (χ a) = χ a)"
using a vcomp_ide_dom χa.natural_transformation_axioms by simp
have "?P a (?L a)" using assms a L_arr [of l χ a] by fastforce
moreover have "?P a (l a)"
proof -
have "?P a (l a) ⟷ l a ∈ B.hom (l a) (l a) ∧ χa.D.cones_map (l a) (χ a) = χ a"
using Pa by meson
thus ?thesis
using a χa.ide_apex χa.cone_axioms χa.D.cones_map_ide [of "χ a" "l a"] by force
qed
moreover have "∃!f. ?P a f"
using a Pa χa.is_universal χa.cone_axioms by force
ultimately show "?L a = l a" by blast
qed
lemma chosen_limits_induce_functor:
assumes "∀a. A.ide a ⟶ limit_cone J B (λj. D (j, a)) (l a) (χ a)"
shows "functor A B (L l χ)"
proof -
let ?L = "L l χ"
let ?P = "λa. λf. «f : l (A.dom a) →⇩B l (A.cod a)» ∧
diagram.cones_map J B (λj. D (j, A.cod a)) f (χ (A.cod a))
= vertical_composite.map J B (χ (A.dom a)) (λj. D (j, a))"
interpret L: "functor" A B ?L
apply unfold_locales
using assms L_arr [of l] L_ide
apply auto[4]
proof -
fix a' a
assume 1: "A.arr (A a' a)"
have a: "A.arr a" using 1 by auto
have a': "«a' : A.cod a →⇩A A.cod a'»" using 1 by auto
have a'a: "A.seq a' a" using 1 by auto
interpret χ_dom_a: limit_cone J B ‹λj. D (j, A.dom a)› ‹l (A.dom a)› ‹χ (A.dom a)›
using a assms by auto
interpret χ_cod_a: limit_cone J B ‹λj. D (j, A.cod a)› ‹l (A.cod a)› ‹χ (A.cod a)›
using a'a assms by auto
interpret χ_dom_a'a: limit_cone J B ‹λj. D (j, A.dom (a' ⋅⇩A a))› ‹l (A.dom (a' ⋅⇩A a))›
‹χ (A.dom (a' ⋅⇩A a))›
using a'a assms by auto
interpret χ_cod_a'a: limit_cone J B ‹λj. D (j, A.cod (a' ⋅⇩A a))› ‹l (A.cod (a' ⋅⇩A a))›
‹χ (A.cod (a' ⋅⇩A a))›
using a'a assms by auto
interpret Da: natural_transformation J B
‹λj. D (j, A.dom a)› ‹λj. D (j, A.cod a)› ‹λj. D (j, a)›
using a fixing_arr_gives_natural_transformation_2 by simp
interpret Da': natural_transformation J B
‹λj. D (j, A.cod a)› ‹λj. D (j, A.cod (a' ⋅⇩A a))› ‹λj. D (j, a')›
using a a'a fixing_arr_gives_natural_transformation_2 by fastforce
interpret Da'oχ_cod_a: vertical_composite J B
χ_cod_a.A.map ‹λj. D (j, A.cod a)› ‹λj. D (j, A.cod (a' ⋅⇩A a))›
‹χ (A.cod a)› ‹λj. D (j, a')›..
interpret Da'oχ_cod_a: cone J B ‹λj. D (j, A.cod (a' ⋅⇩A a))› ‹l (A.cod a)› Da'oχ_cod_a.map
..
interpret Da'a: natural_transformation J B
‹λj. D (j, A.dom (a' ⋅⇩A a))› ‹λj. D (j, A.cod (a' ⋅⇩A a))›
‹λj. D (j, a' ⋅⇩A a)›
using a'a fixing_arr_gives_natural_transformation_2 [of "a' ⋅⇩A a"] by auto
interpret Da'aoχ_dom_a'a:
vertical_composite J B χ_dom_a'a.A.map ‹λj. D (j, A.dom (a' ⋅⇩A a))›
‹λj. D (j, A.cod (a' ⋅⇩A a))› ‹χ (A.dom (a' ⋅⇩A a))›
‹λj. D (j, a' ⋅⇩A a)› ..
interpret Da'aoχ_dom_a'a: cone J B ‹λj. D (j, A.cod (a' ⋅⇩A a))›
‹l (A.dom (a' ⋅⇩A a))› Da'aoχ_dom_a'a.map ..
show "?L (a' ⋅⇩A a) = ?L a' ⋅⇩B ?L a"
proof -
have "?P (a' ⋅⇩A a) (?L (a' ⋅⇩A a))" using assms a'a L_arr [of l χ "a' ⋅⇩A a"] by fastforce
moreover have "?P (a' ⋅⇩A a) (?L a' ⋅⇩B ?L a)"
proof
have La: "«?L a : l (A.dom a) →⇩B l (A.cod a)»"
using assms a L_arr by fast
moreover have La': "«?L a' : l (A.cod a) →⇩B l (A.cod a')»"
using assms a a' L_arr [of l χ a'] by auto
ultimately have seq: "B.seq (?L a') (?L a)" by (elim B.in_homE, auto)
thus La'_La: "«?L a' ⋅⇩B ?L a : l (A.dom (a' ⋅⇩A a)) →⇩B l (A.cod (a' ⋅⇩A a))»"
using a a' 1 La La' by (intro B.comp_in_homI, auto)
show "χ_cod_a'a.D.cones_map (?L a' ⋅⇩B ?L a) (χ (A.cod (a' ⋅⇩A a)))
= Da'aoχ_dom_a'a.map"
proof -
have "χ_cod_a'a.D.cones_map (?L a' ⋅⇩B ?L a) (χ (A.cod (a' ⋅⇩A a)))
= (χ_cod_a'a.D.cones_map (?L a) o χ_cod_a'a.D.cones_map (?L a'))
(χ (A.cod a'))"
proof -
have "χ_cod_a'a.D.cones_map (?L a' ⋅⇩B ?L a) (χ (A.cod (a' ⋅⇩A a))) =
restrict (χ_cod_a'a.D.cones_map (?L a) ∘ χ_cod_a'a.D.cones_map (?L a'))
(χ_cod_a'a.D.cones (B.cod (?L a')))
(χ (A.cod (a' ⋅⇩A a)))"
using seq χ_cod_a'a.cone_axioms χ_cod_a'a.D.cones_map_comp [of "?L a'" "?L a"]
by argo
also have "... = (χ_cod_a'a.D.cones_map (?L a) o χ_cod_a'a.D.cones_map (?L a'))
(χ (A.cod a'))"
proof -
have "χ (A.cod a') ∈ χ_cod_a'a.D.cones (l (A.cod a'))"
using χ_cod_a'a.cone_axioms a'a by simp
moreover have "B.cod (?L a') = l (A.cod a')"
using assms a' L_arr [of l] by auto
ultimately show ?thesis
using a' a'a by simp
qed
finally show ?thesis by blast
qed
also have "... = χ_cod_a'a.D.cones_map (?L a)
(χ_cod_a'a.D.cones_map (?L a') (χ (A.cod a')))"
by simp
also have "... = χ_cod_a'a.D.cones_map (?L a) Da'oχ_cod_a.map"
proof -
have "?P a' (?L a')" using assms a' L_arr [of l χ a'] by fast
moreover have
"?P a' = (λf. f ∈ B.hom (l (A.cod a)) (l (A.cod a')) ∧
χ_cod_a'a.D.cones_map f (χ (A.cod a')) = Da'oχ_cod_a.map)"
using a'a by force
ultimately show ?thesis using a'a by force
qed
also have "... = vertical_composite.map J B
(χ_cod_a.D.cones_map (?L a) (χ (A.cod a)))
(λj. D (j, a'))"
using assms χ_cod_a.D.diagram_axioms χ_cod_a'a.D.diagram_axioms
Da'.natural_transformation_axioms χ_cod_a.cone_axioms La
cones_map_vcomp [of J B "λj. D (j, A.cod a)" "λj. D (j, A.cod (a' ⋅⇩A a))"
"λj. D (j, a')" "l (A.cod a)" "χ (A.cod a)"
"?L a" "l (A.dom a)"]
by blast
also have "... = vertical_composite.map J B
(vertical_composite.map J B (χ (A.dom a)) (λj. D (j, a)))
(λj. D (j, a'))"
using assms a L_arr by presburger
also have "... = vertical_composite.map J B (χ (A.dom a))
(vertical_composite.map J B (λj. D (j, a)) (λj. D (j, a')))"
using a'a Da.natural_transformation_axioms Da'.natural_transformation_axioms
χ_dom_a.natural_transformation_axioms vcomp_assoc
by auto
also have
"... = vertical_composite.map J B (χ (A.dom (a' ⋅⇩A a))) (λj. D (j, a' ⋅⇩A a))"
using a'a preserves_comp_2 by simp
finally show ?thesis by auto
qed
qed
moreover have "∃!f. ?P (a' ⋅⇩A a) f"
using χ_cod_a'a.is_universal
[of "l (A.dom (a' ⋅⇩A a))"
"vertical_composite.map J B (χ (A.dom (a' ⋅⇩A a))) (λj. D (j, a' ⋅⇩A a))"]
Da'aoχ_dom_a'a.cone_axioms
by fast
ultimately show ?thesis by blast
qed
qed
show ?thesis ..
qed
end
locale diagram_in_functor_category =
A: category A +
B: category B +
A_B: functor_category A B +
diagram J A_B.comp D
for A :: "'a comp" (infixr "⋅⇩A" 55)
and B :: "'b comp" (infixr "⋅⇩B" 55)
and J :: "'j comp" (infixr "⋅⇩J" 55)
and D :: "'j ⇒ ('a, 'b) functor_category.arr"
begin
interpretation JxA: product_category J A ..
interpretation A_BxA: product_category A_B.comp A ..
interpretation E: evaluation_functor A B ..
interpretation Curry: currying J A B ..
notation JxA.comp (infixr "⋅⇩J⇩x⇩A" 55)
notation JxA.in_hom ("«_ : _ →⇩J⇩x⇩A _»")
text‹
Evaluation of a functor or natural transformation from @{term[source=true] J}
to ‹[A, B]› at an arrow @{term a} of @{term[source=true] A}.
›
abbreviation at
where "at a τ ≡ λj. Curry.uncurry τ (j, a)"
lemma at_simp:
assumes "A.arr a" and "J.arr j" and "A_B.arr (τ j)"
shows "at a τ j = A_B.Map (τ j) a"
using assms Curry.uncurry_def E.map_simp by simp
lemma functor_at_ide_is_functor:
assumes "functor J A_B.comp F" and "A.ide a"
shows "functor J B (at a F)"
proof -
interpret uncurry_F: "functor" JxA.comp B ‹Curry.uncurry F›
using assms(1) Curry.uncurry_preserves_functors by simp
interpret uncurry_F: binary_functor J A B ‹Curry.uncurry F› ..
show ?thesis using assms(2) uncurry_F.fixing_ide_gives_functor_2 by simp
qed
lemma functor_at_arr_is_transformation:
assumes "functor J A_B.comp F" and "A.arr a"
shows "natural_transformation J B (at (A.dom a) F) (at (A.cod a) F) (at a F)"
proof -
interpret uncurry_F: "functor" JxA.comp B ‹Curry.uncurry F›
using assms(1) Curry.uncurry_preserves_functors by simp
interpret uncurry_F: binary_functor J A B ‹Curry.uncurry F› ..
show ?thesis
using assms(2) uncurry_F.fixing_arr_gives_natural_transformation_2 by simp
qed
lemma transformation_at_ide_is_transformation:
assumes "natural_transformation J A_B.comp F G τ" and "A.ide a"
shows "natural_transformation J B (at a F) (at a G) (at a τ)"
proof -
interpret τ: natural_transformation J A_B.comp F G τ using assms(1) by auto
interpret uncurry_F: "functor" JxA.comp B ‹Curry.uncurry F›
using Curry.uncurry_preserves_functors τ.F.functor_axioms by simp
interpret uncurry_f: binary_functor J A B ‹Curry.uncurry F› ..
interpret uncurry_G: "functor" JxA.comp B ‹Curry.uncurry G›
using Curry.uncurry_preserves_functors τ.G.functor_axioms by simp
interpret uncurry_G: binary_functor J A B ‹Curry.uncurry G› ..
interpret uncurry_τ: natural_transformation
JxA.comp B ‹Curry.uncurry F› ‹Curry.uncurry G› ‹Curry.uncurry τ›
using Curry.uncurry_preserves_transformations τ.natural_transformation_axioms
by simp
interpret uncurry_τ: binary_functor_transformation J A B
‹Curry.uncurry F› ‹Curry.uncurry G› ‹Curry.uncurry τ› ..
show ?thesis
using assms(2) uncurry_τ.fixing_ide_gives_natural_transformation_2 by simp
qed
lemma constant_at_ide_is_constant:
assumes "cone x χ" and a: "A.ide a"
shows "at a (constant_functor.map J A_B.comp x) =
constant_functor.map J B (A_B.Map x a)"
proof -
interpret χ: cone J A_B.comp D x χ using assms(1) by auto
have x: "A_B.ide x" using χ.ide_apex by auto
interpret Fun_x: "functor" A B ‹A_B.Map x›
using x A_B.ide_char by simp
interpret Da: "functor" J B ‹at a D›
using a functor_at_ide_is_functor functor_axioms by blast
interpret Da: diagram J B ‹at a D› ..
interpret Xa: constant_functor J B ‹A_B.Map x a›
using a Fun_x.preserves_ide by unfold_locales simp
show "at a χ.A.map = Xa.map"
using a x Curry.uncurry_def E.map_def Xa.is_extensional by auto
qed
lemma at_ide_is_diagram:
assumes a: "A.ide a"
shows "diagram J B (at a D)"
proof -
interpret Da: "functor" J B "at a D"
using a functor_at_ide_is_functor functor_axioms by simp
show ?thesis ..
qed
lemma cone_at_ide_is_cone:
assumes "cone x χ" and a: "A.ide a"
shows "diagram.cone J B (at a D) (A_B.Map x a) (at a χ)"
proof -
interpret χ: cone J A_B.comp D x χ using assms(1) by auto
have x: "A_B.ide x" using χ.ide_apex by auto
interpret Fun_x: "functor" A B ‹A_B.Map x›
using x A_B.ide_char by simp
interpret Da: diagram J B ‹at a D› using a at_ide_is_diagram by auto
interpret Xa: constant_functor J B ‹A_B.Map x a›
using a by (unfold_locales, simp)
interpret χa: natural_transformation J B Xa.map ‹at a D› ‹at a χ›
using assms(1) x a transformation_at_ide_is_transformation χ.natural_transformation_axioms
constant_at_ide_is_constant
by fastforce
interpret χa: cone J B ‹at a D› ‹A_B.Map x a› ‹at a χ› ..
show cone_χa: "Da.cone (A_B.Map x a) (at a χ)" ..
qed
lemma at_preserves_comp:
assumes "A.seq a' a"
shows "at (A a' a) D = vertical_composite.map J B (at a D) (at a' D)"
proof -
interpret Da: natural_transformation J B ‹at (A.dom a) D› ‹at (A.cod a) D› ‹at a D›
using assms functor_at_arr_is_transformation functor_axioms by blast
interpret Da': natural_transformation J B ‹at (A.cod a) D› ‹at (A.cod a') D› ‹at a' D›
using assms functor_at_arr_is_transformation [of D a'] functor_axioms by fastforce
interpret Da'oDa: vertical_composite J B
‹at (A.dom a) D› ‹at (A.cod a) D› ‹at (A.cod a') D›
‹at a D› ‹at a' D› ..
interpret Da'a: natural_transformation J B ‹at (A.dom a) D› ‹at (A.cod a') D›
‹at (a' ⋅⇩A a) D›
using assms functor_at_arr_is_transformation [of D "a' ⋅⇩A a"] functor_axioms by simp
show "at (a' ⋅⇩A a) D = Da'oDa.map"
proof (intro NaturalTransformation.eqI)
show "natural_transformation J B (at (A.dom a) D) (at (A.cod a') D) Da'oDa.map" ..
show "natural_transformation J B (at (A.dom a) D) (at (A.cod a') D) (at (a' ⋅⇩A a) D)" ..
show "⋀j. J.ide j ⟹ at (a' ⋅⇩A a) D j = Da'oDa.map j"
proof -
fix j
assume j: "J.ide j"
interpret Dj: "functor" A B ‹A_B.Map (D j)›
using j preserves_ide A_B.ide_char by simp
show "at (a' ⋅⇩A a) D j = Da'oDa.map j"
using assms j Dj.preserves_comp at_simp Da'oDa.map_simp_ide by auto
qed
qed
qed
lemma cones_map_pointwise:
assumes "cone x χ" and "cone x' χ'"
and f: "f ∈ A_B.hom x' x"
shows "cones_map f χ = χ' ⟷
(∀a. A.ide a ⟶ diagram.cones_map J B (at a D) (A_B.Map f a) (at a χ) = at a χ')"
proof
interpret χ: cone J A_B.comp D x χ using assms(1) by auto
interpret χ': cone J A_B.comp D x' χ' using assms(2) by auto
have x: "A_B.ide x" using χ.ide_apex by auto
have x': "A_B.ide x'" using χ'.ide_apex by auto
interpret χf: cone J A_B.comp D x' ‹cones_map f χ›
using x' f assms(1) cones_map_mapsto by blast
interpret Fun_x: "functor" A B ‹A_B.Map x› using x A_B.ide_char by simp
interpret Fun_x': "functor" A B ‹A_B.Map x'› using x' A_B.ide_char by simp
show "cones_map f χ = χ' ⟹
(∀a. A.ide a ⟶ diagram.cones_map J B (at a D) (A_B.Map f a) (at a χ) = at a χ')"
proof -
assume χ': "cones_map f χ = χ'"
have "⋀a. A.ide a ⟹ diagram.cones_map J B (at a D) (A_B.Map f a) (at a χ) = at a χ'"
proof -
fix a
assume a: "A.ide a"
interpret Da: diagram J B ‹at a D› using a at_ide_is_diagram by auto
interpret χa: cone J B ‹at a D› ‹A_B.Map x a› ‹at a χ›
using a assms(1) cone_at_ide_is_cone by simp
interpret χ'a: cone J B ‹at a D› ‹A_B.Map x' a› ‹at a χ'›
using a assms(2) cone_at_ide_is_cone by simp
have 1: "«A_B.Map f a : A_B.Map x' a →⇩B A_B.Map x a»"
using f a A_B.arr_char A_B.Map_cod A_B.Map_dom mem_Collect_eq
natural_transformation.preserves_hom A.ide_in_hom
by (metis (no_types, lifting) A_B.in_homE)
interpret χfa: cone J B ‹at a D› ‹A_B.Map x' a›
‹Da.cones_map (A_B.Map f a) (at a χ)›
using 1 χa.cone_axioms Da.cones_map_mapsto by force
show "Da.cones_map (A_B.Map f a) (at a χ) = at a χ'"
proof
fix j
have "¬J.arr j ⟹ Da.cones_map (A_B.Map f a) (at a χ) j = at a χ' j"
using χ'a.is_extensional χfa.is_extensional [of j] by simp
moreover have "J.arr j ⟹ Da.cones_map (A_B.Map f a) (at a χ) j = at a χ' j"
using a f 1 χ.cone_axioms χa.cone_axioms at_simp
apply simp
apply (elim A_B.in_homE B.in_homE, auto)
using χ' χ.A.map_simp A_B.Map_comp [of "χ j" f a a] by auto
ultimately show "Da.cones_map (A_B.Map f a) (at a χ) j = at a χ' j" by blast
qed
qed
thus "∀a. A.ide a ⟶ diagram.cones_map J B (at a D) (A_B.Map f a) (at a χ) = at a χ'"
by simp
qed
show "∀a. A.ide a ⟶ diagram.cones_map J B (at a D) (A_B.Map f a) (at a χ) = at a χ'
⟹ cones_map f χ = χ'"
proof -
assume A:
"∀a. A.ide a ⟶ diagram.cones_map J B (at a D) (A_B.Map f a) (at a χ) = at a χ'"
show "cones_map f χ = χ'"
proof (intro NaturalTransformation.eqI)
show "natural_transformation J A_B.comp χ'.A.map D (cones_map f χ)" ..
show "natural_transformation J A_B.comp χ'.A.map D χ'" ..
show "⋀j. J.ide j ⟹ cones_map f χ j = χ' j"
proof (intro A_B.arr_eqI)
fix j
assume j: "J.ide j"
show 1: "A_B.arr (cones_map f χ j)"
using j χf.preserves_reflects_arr by simp
show "A_B.arr (χ' j)" using j by auto
have Dom_χf_j: "A_B.Dom (cones_map f χ j) = A_B.Map x'"
using x' j 1 A_B.Map_dom χ'.A.map_simp χf.preserves_dom J.ide_in_hom
by (metis (no_types, lifting) J.ideD(2) χf.preserves_reflects_arr)
also have Dom_χ'_j: "... = A_B.Dom (χ' j)"
using x' j A_B.Map_dom [of "χ' j"] χ'.preserves_hom χ'.A.map_simp by simp
finally show "A_B.Dom (cones_map f χ j) = A_B.Dom (χ' j)" by auto
have Cod_χf_j: "A_B.Cod (cones_map f χ j) = A_B.Map (D (J.cod j))"
using j A_B.Map_cod A_B.cod_char J.ide_in_hom χf.preserves_hom
by (metis (no_types, lifting) "1" J.ideD(1) χf.preserves_cod)
also have Cod_χ'_j: "... = A_B.Cod (χ' j)"
using j A_B.Map_cod [of "χ' j"] χ'.preserves_hom by simp
finally show "A_B.Cod (cones_map f χ j) = A_B.Cod (χ' j)" by auto
show "A_B.Map (cones_map f χ j) = A_B.Map (χ' j)"
proof (intro NaturalTransformation.eqI)
interpret χfj: natural_transformation A B ‹A_B.Map x'› ‹A_B.Map (D (J.cod j))›
‹A_B.Map (cones_map f χ j)›
using j χf.preserves_reflects_arr A_B.arr_char [of "cones_map f χ j"]
Dom_χf_j Cod_χf_j
by simp
show "natural_transformation A B (A_B.Map x') (A_B.Map (D (J.cod j)))
(A_B.Map (cones_map f χ j))" ..
interpret χ'j: natural_transformation A B ‹A_B.Map x'› ‹A_B.Map (D (J.cod j))›
‹A_B.Map (χ' j)›
using j A_B.arr_char [of "χ' j"] Dom_χ'_j Cod_χ'_j by simp
show "natural_transformation A B (A_B.Map x') (A_B.Map (D (J.cod j)))
(A_B.Map (χ' j))" ..
show "⋀a. A.ide a ⟹ A_B.Map (cones_map f χ j) a = A_B.Map (χ' j) a"
proof -
fix a
assume a: "A.ide a"
interpret Da: diagram J B ‹at a D› using a at_ide_is_diagram by auto
have cone_χa: "Da.cone (A_B.Map x a) (at a χ)"
using a assms(1) cone_at_ide_is_cone by simp
interpret χa: cone J B ‹at a D› ‹A_B.Map x a› ‹at a χ›
using cone_χa by auto
interpret Fun_f: natural_transformation A B ‹A_B.Dom f› ‹A_B.Cod f›
‹A_B.Map f›
using f A_B.arr_char by fast
have fa: "A_B.Map f a ∈ B.hom (A_B.Map x' a) (A_B.Map x a)"
using a f Fun_f.preserves_hom A.ide_in_hom by auto
have "A_B.Map (cones_map f χ j) a = Da.cones_map (A_B.Map f a) (at a χ) j"
proof -
have "A_B.Map (cones_map f χ j) a = A_B.Map (A_B.comp (χ j) f) a"
using assms(1) f χ.is_extensional by auto
also have "... = B (A_B.Map (χ j) a) (A_B.Map f a)"
using f j a χ.preserves_hom A.ide_in_hom J.ide_in_hom A_B.Map_comp
χ.A.map_simp
by (metis (no_types, lifting) A.comp_ide_self A.ideD(1) A_B.seqI'
J.ideD(1) mem_Collect_eq)
also have "... = Da.cones_map (A_B.Map f a) (at a χ) j"
using j a cone_χa fa Curry.uncurry_def E.map_simp by auto
finally show ?thesis by auto
qed
also have "... = at a χ' j" using j a A by simp
also have "... = A_B.Map (χ' j) a"
using j Curry.uncurry_def E.map_simp χ'j.is_extensional by simp
finally show "A_B.Map (cones_map f χ j) a = A_B.Map (χ' j) a" by auto
qed
qed
qed
qed
qed
qed
text‹
If @{term χ} is a cone with apex @{term a} over @{term D}, then @{term χ}
is a limit cone if, for each object @{term x} of @{term X}, the cone obtained
by evaluating @{term χ} at @{term x} is a limit cone with apex @{term "A_B.Map a x"}
for the diagram in @{term C} obtained by evaluating @{term D} at @{term x}.
›
lemma cone_is_limit_if_pointwise_limit:
assumes cone_χ: "cone x χ"
and "∀a. A.ide a ⟶ diagram.limit_cone J B (at a D) (A_B.Map x a) (at a χ)"
shows "limit_cone x χ"
proof -
interpret χ: cone J A_B.comp D x χ using assms by auto
have x: "A_B.ide x" using χ.ide_apex by auto
show "limit_cone x χ"
proof
fix x' χ'
assume cone_χ': "cone x' χ'"
interpret χ': cone J A_B.comp D x' χ' using cone_χ' by auto
have x': "A_B.ide x'" using χ'.ide_apex by auto
text‹
The universality of the limit cone ‹at a χ› yields, for each object
‹a› of ‹A›, a unique arrow ‹fa› that transforms
‹at a χ› to ‹at a χ'›.
›
have EU: "⋀a. A.ide a ⟹
∃!fa. fa ∈ B.hom (A_B.Map x' a) (A_B.Map x a) ∧
diagram.cones_map J B (at a D) fa (at a χ) = at a χ'"
proof -
fix a
assume a: "A.ide a"
interpret Da: diagram J B ‹at a D› using a at_ide_is_diagram by auto
interpret χa: limit_cone J B ‹at a D› ‹A_B.Map x a› ‹at a χ›
using assms(2) a by auto
interpret χ'a: cone J B ‹at a D› ‹A_B.Map x' a› ‹at a χ'›
using a cone_χ' cone_at_ide_is_cone by auto
have "Da.cone (A_B.Map x' a) (at a χ')" ..
thus "∃!fa. fa ∈ B.hom (A_B.Map x' a) (A_B.Map x a) ∧
Da.cones_map fa (at a χ) = at a χ'"
using χa.is_universal by simp
qed
text‹
Our objective is to show the existence of a unique arrow ‹f› that transforms
‹χ› into ‹χ'›. We obtain ‹f› by bundling the arrows ‹fa›
of ‹C› and proving that this yields a natural transformation from ‹X›
to ‹C›, hence an arrow of ‹[X, C]›.
›
show "∃!f. «f : x' →⇩[⇩A⇩,⇩B⇩] x» ∧ cones_map f χ = χ'"
proof
let ?P = "λa fa. «fa : A_B.Map x' a →⇩B A_B.Map x a» ∧
diagram.cones_map J B (at a D) fa (at a χ) = at a χ'"
have AaPa: "⋀a. A.ide a ⟹ ?P a (THE fa. ?P a fa)"
proof -
fix a
assume a: "A.ide a"
have "∃!fa. ?P a fa" using a EU by simp
thus "?P a (THE fa. ?P a fa)" using a theI' [of "?P a"] by fastforce
qed
have AaPa_in_hom:
"⋀a. A.ide a ⟹ «THE fa. ?P a fa : A_B.Map x' a →⇩B A_B.Map x a»"
using AaPa by blast
have AaPa_map:
"⋀a. A.ide a ⟹
diagram.cones_map J B (at a D) (THE fa. ?P a fa) (at a χ) = at a χ'"
using AaPa by blast
let ?Fun_f = "λa. if A.ide a then (THE fa. ?P a fa) else B.null"
interpret Fun_x: "functor" A B ‹λa. A_B.Map x a›
using x A_B.ide_char by simp
interpret Fun_x': "functor" A B ‹λa. A_B.Map x' a›
using x' A_B.ide_char by simp
text‹
The arrows ‹Fun_f a› are the components of a natural transformation.
It is more work to verify the naturality than it seems like it ought to be.
›
interpret φ: transformation_by_components A B
‹λa. A_B.Map x' a› ‹λa. A_B.Map x a› ?Fun_f
proof
fix a
assume a: "A.ide a"
show "«?Fun_f a : A_B.Map x' a →⇩B A_B.Map x a»" using a AaPa by simp
next
fix a
assume a: "A.arr a"
text‹
\newcommand\xdom{\mathop{\rm dom}}
\newcommand\xcod{\mathop{\rm cod}}
$$\xymatrix{
{x_{\xdom a}} \drtwocell\omit{\omit(A)} \ar[d]_{\chi_{\xdom a}} \ar[r]^{x_a} & {x_{\xcod a}}
\ar[d]^{\chi_{\xcod a}} \\
{D_{\xdom a}} \ar[r]^{D_a} & {D_{\xcod a}} \\
{x'_{\xdom a}} \urtwocell\omit{\omit(B)} \ar@/^5em/[uu]^{f_{\xdom a}}_{\hspace{1em}(C)} \ar[u]^{\chi'_{\xdom a}}
\ar[r]_{x'_a} & {x'_{\xcod a}} \ar[u]_{x'_{\xcod a}} \ar@/_5em/[uu]_{f_{\xcod a}}
}$$
›
let ?x_dom_a = "A_B.Map x (A.dom a)"
let ?x_cod_a = "A_B.Map x (A.cod a)"
let ?x_a = "A_B.Map x a"
have x_a: "«?x_a : ?x_dom_a →⇩B ?x_cod_a»"
using a x A_B.ide_char by auto
let ?x'_dom_a = "A_B.Map x' (A.dom a)"
let ?x'_cod_a = "A_B.Map x' (A.cod a)"
let ?x'_a = "A_B.Map x' a"
have x'_a: "«?x'_a : ?x'_dom_a →⇩B ?x'_cod_a»"
using a x' A_B.ide_char by auto
let ?f_dom_a = "?Fun_f (A.dom a)"
let ?f_cod_a = "?Fun_f (A.cod a)"
have f_dom_a: "«?f_dom_a : ?x'_dom_a →⇩B ?x_dom_a»" using a AaPa by simp
have f_cod_a: "«?f_cod_a : ?x'_cod_a →⇩B ?x_cod_a»" using a AaPa by simp
interpret D_dom_a: diagram J B ‹at (A.dom a) D› using a at_ide_is_diagram by simp
interpret D_cod_a: diagram J B ‹at (A.cod a) D› using a at_ide_is_diagram by simp
interpret Da: natural_transformation J B ‹at (A.dom a) D› ‹at (A.cod a) D› ‹at a D›
using a functor_axioms functor_at_arr_is_transformation by simp
interpret χ_dom_a: limit_cone J B ‹at (A.dom a) D› ‹A_B.Map x (A.dom a)›
‹at (A.dom a) χ›
using assms(2) a by auto
interpret χ_cod_a: limit_cone J B ‹at (A.cod a) D› ‹A_B.Map x (A.cod a)›
‹at (A.cod a) χ›
using assms(2) a by auto
interpret χ'_dom_a: cone J B ‹at (A.dom a) D› ‹A_B.Map x' (A.dom a)›
‹at (A.dom a) χ'›
using a cone_χ' cone_at_ide_is_cone by auto
interpret χ'_cod_a: cone J B ‹at (A.cod a) D› ‹A_B.Map x' (A.cod a)›
‹at (A.cod a) χ'›
using a cone_χ' cone_at_ide_is_cone by auto
text‹
Now construct cones with apexes ‹x_dom_a› and ‹x'_dom_a›
over @{term "at (A.cod a) D"} by forming the vertical composites of
@{term "at (A.dom a) χ"} and @{term "at (A.cod a) χ'"} with the natural
transformation @{term "at a D"}.
›
interpret Daoχ_dom_a: vertical_composite J B
χ_dom_a.A.map ‹at (A.dom a) D› ‹at (A.cod a) D›
‹at (A.dom a) χ› ‹at a D› ..
interpret Daoχ_dom_a: cone J B ‹at (A.cod a) D› ?x_dom_a Daoχ_dom_a.map
using χ_dom_a.cone_axioms Da.natural_transformation_axioms vcomp_transformation_cone
by metis
interpret Daoχ'_dom_a: vertical_composite J B
χ'_dom_a.A.map ‹at (A.dom a) D› ‹at (A.cod a) D›
‹at (A.dom a) χ'› ‹at a D› ..
interpret Daoχ'_dom_a: cone J B ‹at (A.cod a) D› ?x'_dom_a Daoχ'_dom_a.map
using χ'_dom_a.cone_axioms Da.natural_transformation_axioms vcomp_transformation_cone
by metis
have Daoχ_dom_a: "D_cod_a.cone ?x_dom_a Daoχ_dom_a.map" ..
have Daoχ'_dom_a: "D_cod_a.cone ?x'_dom_a Daoχ'_dom_a.map" ..
text‹
These cones are also obtained by transforming the cones @{term "at (A.cod a) χ"}
and @{term "at (A.cod a) χ'"} by ‹x_a› and ‹x'_a›, respectively.
›
have A: "Daoχ_dom_a.map = D_cod_a.cones_map ?x_a (at (A.cod a) χ)"
proof
fix j
have "¬J.arr j ⟹ Daoχ_dom_a.map j = D_cod_a.cones_map ?x_a (at (A.cod a) χ) j"
using Daoχ_dom_a.is_extensional χ_cod_a.cone_axioms x_a by force
moreover have
"J.arr j ⟹ Daoχ_dom_a.map j = D_cod_a.cones_map ?x_a (at (A.cod a) χ) j"
proof -
assume j: "J.arr j"
have "Daoχ_dom_a.map j = at a D j ⋅⇩B at (A.dom a) χ (J.dom j)"
using j Daoχ_dom_a.map_simp_2 by simp
also have "... = A_B.Map (D j) a ⋅⇩B A_B.Map (χ (J.dom j)) (A.dom a)"
using a j at_simp by simp
also have "... = A_B.Map (A_B.comp (D j) (χ (J.dom j))) a"
using a j A_B.Map_comp
by (metis (no_types, lifting) A.comp_arr_dom χ.is_natural_1
χ.preserves_reflects_arr)
also have "... = A_B.Map (A_B.comp (χ (J.cod j)) (χ.A.map j)) a"
using a j χ.naturality by simp
also have "... = A_B.Map (χ (J.cod j)) (A.cod a) ⋅⇩B A_B.Map x a"
using a j x A_B.Map_comp
by (metis (no_types, lifting) A.comp_cod_arr χ.A.map_simp χ.is_natural_2
χ.preserves_reflects_arr)
also have "... = at (A.cod a) χ (J.cod j) ⋅⇩B A_B.Map x a"
using a j at_simp by simp
also have "... = at (A.cod a) χ j ⋅⇩B A_B.Map x a"
using a j χ_cod_a.is_natural_2 χ_cod_a.A.map_simp
by (metis J.arr_cod_iff_arr J.cod_cod)
also have "... = D_cod_a.cones_map ?x_a (at (A.cod a) χ) j"
using a j x χ_cod_a.cone_axioms preserves_cod by simp
finally show ?thesis by blast
qed
ultimately show "Daoχ_dom_a.map j = D_cod_a.cones_map ?x_a (at (A.cod a) χ) j"
by blast
qed
have B: "Daoχ'_dom_a.map = D_cod_a.cones_map ?x'_a (at (A.cod a) χ')"
proof
fix j
have "¬J.arr j ⟹
Daoχ'_dom_a.map j = D_cod_a.cones_map ?x'_a (at (A.cod a) χ') j"
using Daoχ'_dom_a.is_extensional χ'_cod_a.cone_axioms x'_a by force
moreover have
"J.arr j ⟹ Daoχ'_dom_a.map j = D_cod_a.cones_map ?x'_a (at (A.cod a) χ') j"
proof -
assume j: "J.arr j"
have "Daoχ'_dom_a.map j = at a D j ⋅⇩B at (A.dom a) χ' (J.dom j)"
using j Daoχ'_dom_a.map_simp_2 by simp
also have "... = A_B.Map (D j) a ⋅⇩B A_B.Map (χ' (J.dom j)) (A.dom a)"
using a j at_simp by simp
also have "... = A_B.Map (A_B.comp (D j) (χ' (J.dom j))) a"
using a j A_B.Map_comp
by (metis (no_types, lifting) A.comp_arr_dom χ'.is_natural_1
χ'.preserves_reflects_arr)
also have "... = A_B.Map (A_B.comp (χ' (J.cod j)) (χ'.A.map j)) a"
using a j χ'.naturality by simp
also have "... = A_B.Map (χ' (J.cod j)) (A.cod a) ⋅⇩B A_B.Map x' a"
using a j x' A_B.Map_comp
by (metis (no_types, lifting) A.comp_cod_arr χ'.A.map_simp χ'.is_natural_2
χ'.preserves_reflects_arr)
also have "... = at (A.cod a) χ' (J.cod j) ⋅⇩B A_B.Map x' a"
using a j at_simp by simp
also have "... = at (A.cod a) χ' j ⋅⇩B A_B.Map x' a"
using a j χ'_cod_a.is_natural_2 χ'_cod_a.A.map_simp
by (metis J.arr_cod_iff_arr J.cod_cod)
also have "... = D_cod_a.cones_map ?x'_a (at (A.cod a) χ') j"
using a j x' χ'_cod_a.cone_axioms preserves_cod by simp
finally show ?thesis by blast
qed
ultimately show
"Daoχ'_dom_a.map j = D_cod_a.cones_map ?x'_a (at (A.cod a) χ') j"
by blast
qed
text‹
Next, we show that ‹f_dom_a›, which is the unique arrow that transforms
‹χ_dom_a› into ‹χ'_dom_a›, is also the unique arrow that transforms
‹Daoχ_dom_a› into ‹Daoχ'_dom_a›.
›
have C: "D_cod_a.cones_map ?f_dom_a Daoχ_dom_a.map = Daoχ'_dom_a.map"
proof (intro NaturalTransformation.eqI)
show "natural_transformation
J B χ'_dom_a.A.map (at (A.cod a) D) Daoχ'_dom_a.map" ..
show "natural_transformation J B χ'_dom_a.A.map (at (A.cod a) D)
(D_cod_a.cones_map ?f_dom_a Daoχ_dom_a.map)"
proof -
interpret κ: cone J B ‹at (A.cod a) D› ?x'_dom_a
‹D_cod_a.cones_map ?f_dom_a Daoχ_dom_a.map›
proof -
have "⋀b b' f. ⟦ f ∈ B.hom b' b; D_cod_a.cone b Daoχ_dom_a.map ⟧
⟹ D_cod_a.cone b' (D_cod_a.cones_map f Daoχ_dom_a.map)"
using D_cod_a.cones_map_mapsto by blast
moreover have "D_cod_a.cone ?x_dom_a Daoχ_dom_a.map" ..
ultimately show "D_cod_a.cone ?x'_dom_a
(D_cod_a.cones_map ?f_dom_a Daoχ_dom_a.map)"
using f_dom_a by simp
qed
show ?thesis ..
qed
show "⋀j. J.ide j ⟹
D_cod_a.cones_map ?f_dom_a Daoχ_dom_a.map j = Daoχ'_dom_a.map j"
proof -
fix j
assume j: "J.ide j"
have "D_cod_a.cones_map ?f_dom_a Daoχ_dom_a.map j =
Daoχ_dom_a.map j ⋅⇩B ?f_dom_a"
using j f_dom_a Daoχ_dom_a.cone_axioms
by (elim B.in_homE, auto)
also have "... = (at a D j ⋅⇩B at (A.dom a) χ j) ⋅⇩B ?f_dom_a"
using j Daoχ_dom_a.map_simp_ide by simp
also have "... = at a D j ⋅⇩B at (A.dom a) χ j ⋅⇩B ?f_dom_a"
using B.comp_assoc by simp
also have "... = at a D j ⋅⇩B D_dom_a.cones_map ?f_dom_a (at (A.dom a) χ) j"
using j χ_dom_a.cone_axioms f_dom_a
by (elim B.in_homE, auto)
also have "... = at a D j ⋅⇩B at (A.dom a) χ' j"
using a AaPa A.ide_dom by presburger
also have "... = Daoχ'_dom_a.map j"
using j Daoχ'_dom_a.map_simp_ide by simp
finally show
"D_cod_a.cones_map ?f_dom_a Daoχ_dom_a.map j = Daoχ'_dom_a.map j"
by auto
qed
qed
text‹
Naturality amounts to showing that ‹C f_cod_a x'_a = C x_a f_dom_a›.
To do this, we show that both arrows transform @{term "at (A.cod a) χ"}
into ‹Daoχ'_cod_a›, thus they are equal by the universality of
@{term "at (A.cod a) χ"}.
›
have "∃!fa. «fa : ?x'_dom_a →⇩B ?x_cod_a» ∧
D_cod_a.cones_map fa (at (A.cod a) χ) = Daoχ'_dom_a.map"
using Daoχ'_dom_a.cone_axioms a χ_cod_a.is_universal [of ?x'_dom_a Daoχ'_dom_a.map]
by fast
moreover have
"?f_cod_a ⋅⇩B ?x'_a ∈ B.hom ?x'_dom_a ?x_cod_a ∧
D_cod_a.cones_map (?f_cod_a ⋅⇩B ?x'_a) (at (A.cod a) χ) = Daoχ'_dom_a.map"
proof
show "?f_cod_a ⋅⇩B ?x'_a ∈ B.hom ?x'_dom_a ?x_cod_a"
using f_cod_a x'_a by blast
show "D_cod_a.cones_map (?f_cod_a ⋅⇩B ?x'_a) (at (A.cod a) χ) = Daoχ'_dom_a.map"
proof -
have "D_cod_a.cones_map (?f_cod_a ⋅⇩B ?x'_a) (at (A.cod a) χ)
= restrict (D_cod_a.cones_map ?x'_a o D_cod_a.cones_map ?f_cod_a)
(D_cod_a.cones (?x_cod_a))
(at (A.cod a) χ)"
using x'_a D_cod_a.cones_map_comp [of ?f_cod_a ?x'_a] f_cod_a
by (elim B.in_homE, auto)
also have "... = D_cod_a.cones_map ?x'_a
(D_cod_a.cones_map ?f_cod_a (at (A.cod a) χ))"
using χ_cod_a.cone_axioms by simp
also have "... = Daoχ'_dom_a.map"
using a B AaPa_map A.ide_cod by presburger
finally show ?thesis by auto
qed
qed
moreover have
"?x_a ⋅⇩B ?f_dom_a ∈ B.hom ?x'_dom_a ?x_cod_a ∧
D_cod_a.cones_map (?x_a ⋅⇩B ?f_dom_a) (at (A.cod a) χ) = Daoχ'_dom_a.map"
proof
show "?x_a ⋅⇩B ?f_dom_a ∈ B.hom ?x'_dom_a ?x_cod_a"
using f_dom_a x_a by blast
show "D_cod_a.cones_map (?x_a ⋅⇩B ?f_dom_a) (at (A.cod a) χ) = Daoχ'_dom_a.map"
proof -
have
"D_cod_a.cones (B.cod (A_B.Map x a)) = D_cod_a.cones (A_B.Map x (A.cod a))"
using a x by simp
moreover have "B.seq ?x_a ?f_dom_a"
using f_dom_a x_a by (elim B.in_homE, auto)
ultimately have
"D_cod_a.cones_map (?x_a ⋅⇩B ?f_dom_a) (at (A.cod a) χ)
= restrict (D_cod_a.cones_map ?f_dom_a o D_cod_a.cones_map ?x_a)
(D_cod_a.cones (?x_cod_a))
(at (A.cod a) χ)"
using D_cod_a.cones_map_comp [of ?x_a ?f_dom_a] x_a by argo
also have "... = D_cod_a.cones_map ?f_dom_a
(D_cod_a.cones_map ?x_a (at (A.cod a) χ))"
using χ_cod_a.cone_axioms by simp
also have "... = Daoχ'_dom_a.map"
using A C a AaPa by argo
finally show ?thesis by blast
qed
qed
ultimately show "?f_cod_a ⋅⇩B ?x'_a = ?x_a ⋅⇩B ?f_dom_a"
using a χ_cod_a.is_universal by blast
qed
text‹
The arrow from @{term x'} to @{term x} in ‹[A, B]› determined by
the natural transformation ‹φ› transforms @{term χ} into @{term χ'}.
Moreover, it is the unique such arrow, since the components of ‹φ›
are each determined by universality.
›
let ?f = "A_B.MkArr (λa. A_B.Map x' a) (λa. A_B.Map x a) φ.map"
have f_in_hom: "?f ∈ A_B.hom x' x"
proof -
have arr_f: "A_B.arr ?f"
using x' x A_B.arr_MkArr φ.natural_transformation_axioms by simp
moreover have "A_B.MkIde (λa. A_B.Map x a) = x"
using x A_B.ide_char A_B.MkArr_Map A_B.in_homE A_B.ide_in_hom by metis
moreover have "A_B.MkIde (λa. A_B.Map x' a) = x'"
using x' A_B.ide_char A_B.MkArr_Map A_B.in_homE A_B.ide_in_hom by metis
ultimately show ?thesis
using A_B.dom_char A_B.cod_char by auto
qed
have Fun_f: "⋀a. A.ide a ⟹ A_B.Map ?f a = (THE fa. ?P a fa)"
using f_in_hom φ.map_simp_ide by fastforce
have cones_map_f: "cones_map ?f χ = χ'"
using AaPa Fun_f at_ide_is_diagram assms(2) x x' cone_χ cone_χ' f_in_hom Fun_f
cones_map_pointwise
by presburger
show "«?f : x' →⇩[⇩A⇩,⇩B⇩] x» ∧ cones_map ?f χ = χ'" using f_in_hom cones_map_f by auto
show "⋀f'. «f' : x' →⇩[⇩A⇩,⇩B⇩] x» ∧ cones_map f' χ = χ' ⟹ f' = ?f"
proof -
fix f'
assume f': "«f' : x' →⇩[⇩A⇩,⇩B⇩] x» ∧ cones_map f' χ = χ'"
have 0: "⋀a. A.ide a ⟹
diagram.cones_map J B (at a D) (A_B.Map f' a) (at a χ) = at a χ'"
using f' cone_χ cone_χ' cones_map_pointwise by blast
have "f' = A_B.MkArr (A_B.Dom f') (A_B.Cod f') (A_B.Map f')"
using f' A_B.MkArr_Map by auto
also have "... = ?f"
proof (intro A_B.MkArr_eqI)
show "A_B.arr (A_B.MkArr (A_B.Dom f') (A_B.Cod f') (A_B.Map f'))"
using f' calculation by blast
show 1: "A_B.Dom f' = A_B.Map x'" using f' A_B.Map_dom by auto
show 2: "A_B.Cod f' = A_B.Map x" using f' A_B.Map_cod by auto
show "A_B.Map f' = φ.map"
proof (intro NaturalTransformation.eqI)
show "natural_transformation A B (A_B.Map x') (A_B.Map x) φ.map" ..
show "natural_transformation A B (A_B.Map x') (A_B.Map x) (A_B.Map f')"
using f' 1 2 A_B.arr_char [of f'] by auto
show "⋀a. A.ide a ⟹ A_B.Map f' a = φ.map a"
proof -
fix a
assume a: "A.ide a"
interpret Da: diagram J B ‹at a D› using a at_ide_is_diagram by auto
interpret Fun_f': natural_transformation A B ‹A_B.Dom f'› ‹A_B.Cod f'›
‹A_B.Map f'›
using f' A_B.arr_char by fast
have "A_B.Map f' a ∈ B.hom (A_B.Map x' a) (A_B.Map x a)"
using a f' Fun_f'.preserves_hom A.ide_in_hom by auto
hence "?P a (A_B.Map f' a)" using a 0 [of a] by simp
moreover have "?P a (φ.map a)"
using a φ.map_simp_ide Fun_f AaPa by presburger
ultimately show "A_B.Map f' a = φ.map a" using a EU by blast
qed
qed
qed
finally show "f' = ?f" by auto
qed
qed
qed
qed
end
context functor_category
begin
text‹
A functor category ‹[A, B]› has limits of shape @{term[source=true] J}
whenever @{term B} has limits of shape @{term[source=true] J}.
›
lemma has_limits_of_shape_if_target_does:
assumes "category (J :: 'j comp)"
and "B.has_limits_of_shape J"
shows "has_limits_of_shape J"
proof (unfold has_limits_of_shape_def)
have "⋀D. diagram J comp D ⟹ (∃x χ. limit_cone J comp D x χ)"
proof -
fix D
assume D: "diagram J comp D"
interpret J: category J using assms(1) by auto
interpret JxA: product_category J A ..
interpret D: diagram J comp D using D by auto
interpret D: diagram_in_functor_category A B J D ..
interpret Curry: currying J A B ..
text‹
Given diagram @{term D} in ‹[A, B]›, choose for each object ‹a›
of ‹A› a limit cone ‹(la, χa)› for ‹at a D› in ‹B›.
›
let ?l = "λa. diagram.some_limit J B (D.at a D)"
let ?χ = "λa. diagram.some_limit_cone J B (D.at a D)"
have lχ: "⋀a. A.ide a ⟹ diagram.limit_cone J B (D.at a D) (?l a) (?χ a)"
proof -
fix a
assume a: "A.ide a"
interpret Da: diagram J B ‹D.at a D›
using a D.at_ide_is_diagram by blast
show "limit_cone J B (D.at a D) (?l a) (?χ a)"
using assms(2) B.has_limits_of_shape_def Da.diagram_axioms
Da.limit_cone_some_limit_cone
by auto
qed
text‹
The choice of limit cones induces a limit functor from ‹A› to ‹B›.
›
interpret uncurry_D: diagram JxA.comp B "Curry.uncurry D"
proof -
interpret "functor" JxA.comp B ‹Curry.uncurry D›
using D.functor_axioms Curry.uncurry_preserves_functors by simp
interpret binary_functor J A B ‹Curry.uncurry D› ..
show "diagram JxA.comp B (Curry.uncurry D)" ..
qed
interpret uncurry_D: parametrized_diagram J A B ‹Curry.uncurry D› ..
let ?L = "uncurry_D.L ?l ?χ"
let ?P = "uncurry_D.P ?l ?χ"
interpret L: "functor" A B ?L
using lχ uncurry_D.chosen_limits_induce_functor [of ?l ?χ] by simp
have L_ide: "⋀a. A.ide a ⟹ ?L a = ?l a"
using uncurry_D.L_ide [of ?l ?χ] lχ by blast
have L_arr: "⋀a. A.arr a ⟹ (∃!f. ?P a f) ∧ ?P a (?L a)"
using uncurry_D.L_arr [of ?l ?χ] lχ by blast
text‹
The functor ‹L› extends to a functor ‹L'› from ‹JxA›
to ‹B› that is constant on ‹J›.
›
let ?L' = "λja. if JxA.arr ja then ?L (snd ja) else B.null"
let ?P' = "λja. ?P (snd ja)"
interpret L': "functor" JxA.comp B ?L'
apply unfold_locales
using L.preserves_arr L.preserves_dom L.preserves_cod
apply auto[4]
using L.preserves_comp JxA.comp_char by (elim JxA.seqE, auto)
have "⋀ja. JxA.arr ja ⟹ (∃!f. ?P' ja f) ∧ ?P' ja (?L' ja)"
proof -
fix ja
assume ja: "JxA.arr ja"
have "A.arr (snd ja)" using ja by blast
thus "(∃!f. ?P' ja f) ∧ ?P' ja (?L' ja)"
using ja L_arr by presburger
qed
hence L'_arr: "⋀ja. JxA.arr ja ⟹ ?P' ja (?L' ja)" by blast
have L'_ide: "⋀ja. ⟦ J.arr (fst ja); A.ide (snd ja) ⟧ ⟹ ?L' ja = ?l (snd ja)"
using L_ide lχ by force
have L'_arr_map:
"⋀ja. JxA.arr ja ⟹ uncurry_D.P ?l ?χ (snd ja) (uncurry_D.L ?l ?χ (snd ja))"
using L'_arr by presburger
text‹
The map that takes an object ‹(j, a)› of ‹JxA› to the component
‹χ a j› of the limit cone ‹χ a› is a natural transformation
from ‹L› to uncurry ‹D›.
›
let ?χ' = "λja. ?χ (snd ja) (fst ja)"
interpret χ': transformation_by_components JxA.comp B ?L' ‹Curry.uncurry D› ?χ'
proof
fix ja
assume ja: "JxA.ide ja"
let ?j = "fst ja"
let ?a = "snd ja"
interpret χa: limit_cone J B ‹D.at ?a D› ‹?l ?a› ‹?χ ?a›
using ja lχ by blast
show "«?χ' ja : ?L' ja →⇩B Curry.uncurry D ja»"
using ja L'_ide [of ja] by force
next
fix ja
assume ja: "JxA.arr ja"
let ?j = "fst ja"
let ?a = "snd ja"
have j: "J.arr ?j" using ja by simp
have a: "A.arr ?a" using ja by simp
interpret D_dom_a: diagram J B ‹D.at (A.dom ?a) D›
using a D.at_ide_is_diagram by auto
interpret D_cod_a: diagram J B ‹D.at (A.cod ?a) D›
using a D.at_ide_is_diagram by auto
interpret Da: natural_transformation J B
‹D.at (A.dom ?a) D› ‹D.at (A.cod ?a) D› ‹D.at ?a D›
using a D.functor_axioms D.functor_at_arr_is_transformation by simp
interpret χ_dom_a: limit_cone J B ‹D.at (A.dom ?a) D› ‹?l (A.dom ?a)›
‹?χ (A.dom ?a)›
using a lχ by simp
interpret χ_cod_a: limit_cone J B ‹D.at (A.cod ?a) D› ‹?l (A.cod ?a)›
‹?χ (A.cod ?a)›
using a lχ by simp
interpret Daoχ_dom_a: vertical_composite J B
χ_dom_a.A.map ‹D.at (A.dom ?a) D› ‹D.at (A.cod ?a) D›
‹?χ (A.dom ?a)› ‹D.at ?a D›
..
interpret Daoχ_dom_a: cone J B ‹D.at (A.cod ?a) D› ‹?l (A.dom ?a)› Daoχ_dom_a.map ..
show "?χ' (JxA.cod ja) ⋅⇩B ?L' ja = B (Curry.uncurry D ja) (?χ' (JxA.dom ja))"
proof -
have "?χ' (JxA.cod ja) ⋅⇩B ?L' ja = ?χ (A.cod ?a) (J.cod ?j) ⋅⇩B ?L' ja"
using ja by fastforce
also have "... = D_cod_a.cones_map (?L' ja) (?χ (A.cod ?a)) (J.cod ?j)"
using ja L'_arr_map [of ja] χ_cod_a.cone_axioms by auto
also have "... = Daoχ_dom_a.map (J.cod ?j)"
using ja χ_cod_a.induced_arrowI Daoχ_dom_a.cone_axioms L'_arr by presburger
also have "... = D.at ?a D (J.cod ?j) ⋅⇩B D_dom_a.some_limit_cone (J.cod ?j)"
using ja Daoχ_dom_a.map_simp_ide by fastforce
also have "... = D.at ?a D (J.cod ?j) ⋅⇩B D.at (A.dom ?a) D ?j ⋅⇩B ?χ' (JxA.dom ja)"
using ja χ_dom_a.naturality χ_dom_a.ide_apex apply simp
by (metis B.comp_arr_ide χ_dom_a.preserves_reflects_arr)
also have "... = (D.at ?a D (J.cod ?j) ⋅⇩B D.at (A.dom ?a) D ?j) ⋅⇩B ?χ' (JxA.dom ja)"
using j ja B.comp_assoc by presburger
also have "... = B (D.at ?a D ?j) (?χ' (JxA.dom ja))"
using a j ja Map_comp A.comp_arr_dom D.is_natural_2 by simp
also have "... = Curry.uncurry D ja ⋅⇩B ?χ' (JxA.dom ja)"
using Curry.uncurry_def by simp
finally show ?thesis by auto
qed
qed
text‹
Since ‹χ'› is constant on ‹J›, ‹curry χ'› is a cone over ‹D›.
›
interpret constL: constant_functor J comp ‹MkIde ?L›
using L.natural_transformation_axioms MkArr_in_hom ide_in_hom L.functor_axioms
by unfold_locales blast
have curry_L': "constL.map = Curry.curry ?L' ?L' ?L'"
proof
fix j
have "¬J.arr j ⟹ constL.map j = Curry.curry ?L' ?L' ?L' j"
using Curry.curry_def constL.is_extensional by simp
moreover have "J.arr j ⟹ constL.map j = Curry.curry ?L' ?L' ?L' j"
using Curry.curry_def constL.value_is_ide in_homE ide_in_hom by auto
ultimately show "constL.map j = Curry.curry ?L' ?L' ?L' j" by blast
qed
hence uncurry_constL: "Curry.uncurry constL.map = ?L'"
using L'.natural_transformation_axioms Curry.uncurry_curry by simp
interpret curry_χ': natural_transformation J comp constL.map D
‹Curry.curry ?L' (Curry.uncurry D) χ'.map›
proof -
have "Curry.curry (Curry.uncurry D) (Curry.uncurry D) (Curry.uncurry D) = D"
using Curry.curry_uncurry D.functor_axioms D.natural_transformation_axioms
by blast
thus "natural_transformation J comp constL.map D
(Curry.curry ?L' (Curry.uncurry D) χ'.map)"
using Curry.curry_preserves_transformations curry_L' χ'.natural_transformation_axioms
by force
qed
interpret curry_χ': cone J comp D ‹MkIde ?L› ‹Curry.curry ?L' (Curry.uncurry D) χ'.map›
..
text‹
The value of ‹curry_χ'› at each object ‹a› of ‹A› is the
limit cone ‹χ a›, hence ‹curry_χ'› is a limit cone.
›
have 1: "⋀a. A.ide a ⟹ D.at a (Curry.curry ?L' (Curry.uncurry D) χ'.map) = ?χ a"
proof -
fix a
assume a: "A.ide a"
have "D.at a (Curry.curry ?L' (Curry.uncurry D) χ'.map) =
(λj. Curry.uncurry (Curry.curry ?L' (Curry.uncurry D) χ'.map) (j, a))"
using a by simp
moreover have "... = (λj. χ'.map (j, a))"
using a Curry.uncurry_curry χ'.natural_transformation_axioms by simp
moreover have "... = ?χ a"
proof (intro NaturalTransformation.eqI)
interpret χa: limit_cone J B ‹D.at a D› ‹?l a› ‹?χ a› using a lχ by simp
interpret χ': binary_functor_transformation J A B ?L' ‹Curry.uncurry D› χ'.map ..
show "natural_transformation J B χa.A.map (D.at a D) (?χ a)" ..
show "natural_transformation J B χa.A.map (D.at a D) (λj. χ'.map (j, a))"
proof -
have "χa.A.map = (λj. ?L' (j, a))"
using a χa.A.map_def L'_ide by auto
thus ?thesis
using a χ'.fixing_ide_gives_natural_transformation_2 by simp
qed
fix j
assume j: "J.ide j"
show "χ'.map (j, a) = ?χ a j"
using a j χ'.map_simp_ide by simp
qed
ultimately show "D.at a (Curry.curry ?L' (Curry.uncurry D) χ'.map) = ?χ a" by simp
qed
hence 2: "⋀a. A.ide a ⟹ diagram.limit_cone J B (D.at a D) (?l a)
(D.at a (Curry.curry ?L' (Curry.uncurry D) χ'.map))"
using lχ by simp
hence "limit_cone J comp D (MkIde ?L) (Curry.curry ?L' (Curry.uncurry D) χ'.map)"
using 1 2 L.functor_axioms L_ide curry_χ'.cone_axioms curry_L'
D.cone_is_limit_if_pointwise_limit
by simp
thus "∃x χ. limit_cone J comp D x χ" by blast
qed
thus "∀D. diagram J comp D ⟶ (∃x χ. limit_cone J comp D x χ)" by blast
qed
lemma has_limits_if_target_does:
assumes "B.has_limits (undefined :: 'j)"
shows "has_limits (undefined :: 'j)"
using assms B.has_limits_def has_limits_def has_limits_of_shape_if_target_does by fast
end
section "The Yoneda Functor Preserves Limits"
text‹
In this section, we show that the Yoneda functor from ‹C› to ‹[Cop, S]›
preserves limits.
›
context yoneda_functor
begin
lemma preserves_limits:
fixes J :: "'j comp"
assumes "diagram J C D" and "diagram.has_as_limit J C D a"
shows "diagram.has_as_limit J Cop_S.comp (map o D) (map a)"
proof -
text‹
The basic idea of the proof is as follows:
If ‹χ› is a limit cone in ‹C›, then for every object ‹a'›
of ‹Cop› the evaluation of ‹Y o χ› at ‹a'› is a limit cone
in ‹S›. By the results on limits in functor categories,
this implies that ‹Y o χ› is a limit cone in ‹[Cop, S]›.
›
interpret J: category J using assms(1) diagram_def by auto
interpret D: diagram J C D using assms(1) by auto
from assms(2) obtain χ where χ: "D.limit_cone a χ" by blast
interpret χ: limit_cone J C D a χ using χ by auto
have a: "C.ide a" using χ.ide_apex by auto
interpret YoD: diagram J Cop_S.comp ‹map o D›
using D.diagram_axioms functor_axioms preserves_diagrams [of J D] by simp
interpret YoD: diagram_in_functor_category Cop.comp S J ‹map o D› ..
interpret Yoχ: cone J Cop_S.comp ‹map o D› ‹map a› ‹map o χ›
using χ.cone_axioms preserves_cones by blast
have "⋀a'. C.ide a' ⟹
limit_cone J S (YoD.at a' (map o D))
(Cop_S.Map (map a) a') (YoD.at a' (map o χ))"
proof -
fix a'
assume a': "C.ide a'"
interpret A': constant_functor J C a'
using a' by (unfold_locales, auto)
interpret YoD_a': diagram J S ‹YoD.at a' (map o D)›
using a' YoD.at_ide_is_diagram by simp
interpret Yoχ_a': cone J S ‹YoD.at a' (map o D)›
‹Cop_S.Map (map a) a'› ‹YoD.at a' (map o χ)›
using a' YoD.cone_at_ide_is_cone Yoχ.cone_axioms by fastforce
have eval_at_ide: "⋀j. J.ide j ⟹ YoD.at a' (map ∘ D) j = Hom.map (a', D j)"
proof -
fix j
assume j: "J.ide j"
have "YoD.at a' (map ∘ D) j = Cop_S.Map (map (D j)) a'"
using a' j YoD.at_simp YoD.preserves_arr [of j] by auto
also have "... = Y (D j) a'" using Y_def by simp
also have "... = Hom.map (a', D j)" using a' j D.preserves_arr by simp
finally show "YoD.at a' (map ∘ D) j = Hom.map (a', D j)" by auto
qed
have eval_at_arr: "⋀j. J.arr j ⟹ YoD.at a' (map ∘ χ) j = Hom.map (a', χ j)"
proof -
fix j
assume j: "J.arr j"
have "YoD.at a' (map ∘ χ) j = Cop_S.Map ((map o χ) j) a'"
using a' j YoD.at_simp [of a' j "map o χ"] preserves_arr by fastforce
also have "... = Y (χ j) a'" using Y_def by simp
also have "... = Hom.map (a', χ j)" using a' j by simp
finally show "YoD.at a' (map ∘ χ) j = Hom.map (a', χ j)" by auto
qed
have Fun_map_a_a': "Cop_S.Map (map a) a' = Hom.map (a', a)"
using a a' map_simp preserves_arr [of a] by simp
show "limit_cone J S (YoD.at a' (map o D))
(Cop_S.Map (map a) a') (YoD.at a' (map o χ))"
proof
fix x σ
assume σ: "YoD_a'.cone x σ"
interpret σ: cone J S ‹YoD.at a' (map o D)› x σ using σ by auto
have x: "S.ide x" using σ.ide_apex by simp
text‹
For each object ‹j› of ‹J›, the component ‹σ j›
is an arrow in ‹S.hom x (Hom.map (a', D j))›.
Each element ‹e ∈ S.set x› therefore determines an arrow
‹ψ (a', D j) (S.Fun (σ j) e) ∈ C.hom a' (D j)›.
These arrows are the components of a cone ‹κ e› over @{term D}
with apex @{term a'}.
›
have σj: "⋀j. J.ide j ⟹ «σ j : x →⇩S Hom.map (a', D j)»"
using eval_at_ide σ.preserves_hom J.ide_in_hom by force
have κ: "⋀e. e ∈ S.set x ⟹
transformation_by_components
J C A'.map D (λj. ψ (a', D j) (S.Fun (σ j) e))"
proof -
fix e
assume e: "e ∈ S.set x"
show "transformation_by_components J C A'.map D (λj. ψ (a', D j) (S.Fun (σ j) e))"
proof
fix j
assume j: "J.ide j"
show "«ψ (a', D j) (S.Fun (σ j) e) : A'.map j → D j»"
using e j S.Fun_mapsto [of "σ j"] A'.preserves_ide Hom.set_map eval_at_ide
Hom.ψ_mapsto [of "A'.map j" "D j"]
by force
next
fix j
assume j: "J.arr j"
show "ψ (a', D (J.cod j)) (S.Fun (σ (J.cod j)) e) ⋅ A'.map j =
D j ⋅ ψ (a', D (J.dom j)) (S.Fun (σ (J.dom j)) e)"
proof -
have "ψ (a', D (J.cod j)) (S.Fun (σ (J.cod j)) e) ⋅ A'.map j =
ψ (a', D (J.cod j)) (S.Fun (σ (J.cod j)) e) ⋅ a'"
using A'.map_simp j by simp
also have "... = ψ (a', D (J.cod j)) (S.Fun (σ (J.cod j)) e)"
proof -
have "ψ (a', D (J.cod j)) (S.Fun (σ (J.cod j)) e) ∈ C.hom a' (D (J.cod j))"
using a' e j Hom.ψ_mapsto [of "A'.map j" "D (J.cod j)"] A'.map_simp
S.Fun_mapsto [of "σ (J.cod j)"] Hom.set_map eval_at_ide
by auto
thus ?thesis
using C.comp_arr_dom by fastforce
qed
also have "... = ψ (a', D (J.cod j)) (S.Fun (Y (D j) a') (S.Fun (σ (J.dom j)) e))"
proof -
have "S.Fun (Y (D j) a') (S.Fun (σ (J.dom j)) e) =
(S.Fun (Y (D j) a') o S.Fun (σ (J.dom j))) e"
by simp
also have "... = S.Fun (Y (D j) a' ⋅⇩S σ (J.dom j)) e"
using a' e j Y_arr_ide(1) S.in_homE σj eval_at_ide S.Fun_comp by force
also have "... = S.Fun (σ (J.cod j)) e"
using a' j x σ.is_natural_2 σ.A.map_simp S.comp_arr_dom J.arr_cod_iff_arr
J.cod_cod YoD.preserves_arr σ.is_natural_1 YoD.at_simp
by auto
finally have
"S.Fun (Y (D j) a') (S.Fun (σ (J.dom j)) e) = S.Fun (σ (J.cod j)) e"
by auto
thus ?thesis by simp
qed
also have "... = D j ⋅ ψ (a', D (J.dom j)) (S.Fun (σ (J.dom j)) e)"
proof -
have "S.Fun (Y (D j) a') (S.Fun (σ (J.dom j)) e) =
φ (a', D (J.cod j)) (D j ⋅ ψ (a', D (J.dom j)) (S.Fun (σ (J.dom j)) e))"
proof -
have "S.Fun (σ (J.dom j)) e ∈ Hom.set (a', D (J.dom j))"
using a' e j σj S.Fun_mapsto [of "σ (J.dom j)"] Hom.set_map
YoD.at_simp eval_at_ide
by auto
moreover have "C.arr (ψ (a', D (J.dom j)) (S.Fun (σ (J.dom j)) e)) ∧
C.dom (ψ (a', D (J.dom j)) (S.Fun (σ (J.dom j)) e)) = a'"
using a' e j σj S.Fun_mapsto [of "σ (J.dom j)"] Hom.set_map eval_at_ide
Hom.ψ_mapsto [of a' "D (J.dom j)"]
by auto
ultimately show ?thesis
using a' e j Hom.Fun_map C.comp_arr_dom by force
qed
moreover have "D j ⋅ ψ (a', D (J.dom j)) (S.Fun (σ (J.dom j)) e)
∈ C.hom a' (D (J.cod j))"
proof -
have "ψ (a', D (J.dom j)) (S.Fun (σ (J.dom j)) e) ∈ C.hom a' (D (J.dom j))"
using a' e j Hom.ψ_mapsto [of a' "D (J.dom j)"] eval_at_ide
S.Fun_mapsto [of "σ (J.dom j)"] Hom.set_map
by auto
thus ?thesis using j D.preserves_hom by blast
qed
ultimately show ?thesis using a' j Hom.ψ_φ by simp
qed
finally show ?thesis by auto
qed
qed
qed
let ?κ = "λe. transformation_by_components.map J C A'.map
(λj. ψ (a', D j) (S.Fun (σ j) e))"
have cone_κe: "⋀e. e ∈ S.set x ⟹ D.cone a' (?κ e)"
proof -
fix e
assume e: "e ∈ S.set x"
interpret κe: transformation_by_components J C A'.map D
‹λj. ψ (a', D j) (S.Fun (σ j) e)›
using e κ by blast
show "D.cone a' (?κ e)" ..
qed
text‹
Since ‹κ e› is a cone for each element ‹e› of ‹S.set x›,
by the universal property of the limit cone ‹χ› there is a unique arrow
‹fe ∈ C.hom a' a› that transforms ‹χ› to ‹κ e›.
›
have ex_fe: "⋀e. e ∈ S.set x ⟹ ∃!fe. «fe : a' → a» ∧ D.cones_map fe χ = ?κ e"
using cone_κe χ.is_universal by simp
text‹
The map taking ‹e ∈ S.set x› to ‹fe ∈ C.hom a' a›
determines an arrow ‹f ∈ S.hom x (Hom (a', a))› that
transforms the cone obtained by evaluating ‹Y o χ› at ‹a'›
to the cone ‹σ›.
›
let ?f = "S.mkArr (S.set x) (Hom.set (a', a))
(λe. φ (a', a) (χ.induced_arrow a' (?κ e)))"
have 0: "(λe. φ (a', a) (χ.induced_arrow a' (?κ e))) ∈ S.set x → Hom.set (a', a)"
proof
fix e
assume e: "e ∈ S.set x"
interpret κe: cone J C D a' ‹?κ e› using e cone_κe by simp
have "χ.induced_arrow a' (?κ e) ∈ C.hom a' a"
using a a' e ex_fe χ.induced_arrowI κe.cone_axioms by simp
thus "φ (a', a) (χ.induced_arrow a' (?κ e)) ∈ Hom.set (a', a)"
using a a' Hom.φ_mapsto by auto
qed
have f: "«?f : x →⇩S Hom.map (a', a)»"
proof -
have "(λe. φ (a', a) (χ.induced_arrow a' (?κ e))) ∈ S.set x → Hom.set (a', a)"
proof
fix e
assume e: "e ∈ S.set x"
interpret κe: cone J C D a' ‹?κ e› using e cone_κe by simp
have "χ.induced_arrow a' (?κ e) ∈ C.hom a' a"
using a a' e ex_fe χ.induced_arrowI κe.cone_axioms by simp
thus "φ (a', a) (χ.induced_arrow a' (?κ e)) ∈ Hom.set (a', a)"
using a a' Hom.φ_mapsto by auto
qed
thus ?thesis
using a a' x σ.ide_apex S.mkArr_in_hom [of "S.set x" "Hom.set (a', a)"]
Hom.set_subset_Univ S.mkIde_set
by simp
qed
have "YoD_a'.cones_map ?f (YoD.at a' (map o χ)) = σ"
proof (intro NaturalTransformation.eqI)
show "natural_transformation J S σ.A.map (YoD.at a' (map o D)) σ"
using σ.natural_transformation_axioms by auto
have 1: "S.cod ?f = Cop_S.Map (map a) a'"
using f Fun_map_a_a' by force
interpret YoD_a'of: cone J S ‹YoD.at a' (map o D)› x
‹YoD_a'.cones_map ?f (YoD.at a' (map o χ))›
proof -
have "YoD_a'.cone (S.cod ?f) (YoD.at a' (map o χ))"
using a a' f Yoχ_a'.cone_axioms preserves_arr [of a] by auto
hence "YoD_a'.cone (S.dom ?f) (YoD_a'.cones_map ?f (YoD.at a' (map o χ)))"
using f YoD_a'.cones_map_mapsto S.arrI by blast
thus "cone J S (YoD.at a' (map o D)) x
(YoD_a'.cones_map ?f (YoD.at a' (map o χ)))"
using f by auto
qed
show "natural_transformation J S σ.A.map (YoD.at a' (map o D))
(YoD_a'.cones_map ?f (YoD.at a' (map o χ)))" ..
fix j
assume j: "J.ide j"
have "YoD_a'.cones_map ?f (YoD.at a' (map o χ)) j = YoD.at a' (map o χ) j ⋅⇩S ?f"
using f j Fun_map_a_a' Yoχ_a'.cone_axioms by fastforce
also have "... = σ j"
proof (intro S.arr_eqI)
show "S.par (YoD.at a' (map o χ) j ⋅⇩S ?f) (σ j)"
using 1 f j x YoD_a'.preserves_hom by fastforce
show "S.Fun (YoD.at a' (map o χ) j ⋅⇩S ?f) = S.Fun (σ j)"
proof
fix e
have "e ∉ S.set x ⟹ S.Fun (YoD.at a' (map o χ) j ⋅⇩S ?f) e = S.Fun (σ j) e"
using 1 f j x S.Fun_mapsto [of "σ j"] σ.A.map_simp
extensional_arb [of "S.Fun (σ j)"]
by auto
moreover have "e ∈ S.set x ⟹
S.Fun (YoD.at a' (map o χ) j ⋅⇩S ?f) e = S.Fun (σ j) e"
proof -
assume e: "e ∈ S.set x"
interpret κe: transformation_by_components J C A'.map D
‹λj. ψ (a', D j) (S.Fun (σ j) e)›
using e κ by blast
interpret κe: cone J C D a' ‹?κ e› using e cone_κe by simp
have induced_arrow: "χ.induced_arrow a' (?κ e) ∈ C.hom a' a"
using a a' e ex_fe χ.induced_arrowI κe.cone_axioms by simp
have "S.Fun (YoD.at a' (map o χ) j ⋅⇩S ?f) e =
restrict (S.Fun (YoD.at a' (map o χ) j) o S.Fun ?f) (S.set x) e"
using 1 e f j S.Fun_comp YoD_a'.preserves_hom by force
also have "... = (φ (a', D j) o C (χ j) o ψ (a', a)) (S.Fun ?f e)"
using j a' f e Hom.map_simp_2 S.Fun_mkArr Hom.preserves_arr [of "(a', χ j)"]
eval_at_arr S.arr_mkArr
by (elim S.in_homE, auto)
also have "... = (φ (a', D j) o C (χ j) o ψ (a', a))
(φ (a', a) (χ.induced_arrow a' (?κ e)))"
using e f S.Fun_mkArr by fastforce
also have "... = φ (a', D j) (D.cones_map (χ.induced_arrow a' (?κ e)) χ j)"
using a a' e j 0 Hom.ψ_φ induced_arrow χ.cone_axioms by auto
also have "... = φ (a', D j) (?κ e j)"
using χ.induced_arrowI κe.cone_axioms by fastforce
also have "... = φ (a', D j) (ψ (a', D j) (S.Fun (σ j) e))"
using j κe.map_def [of j] by simp
also have "... = S.Fun (σ j) e"
proof -
have "S.Fun (σ j) e ∈ Hom.set (a', D j)"
using a' e j S.Fun_mapsto [of "σ j"] eval_at_ide Hom.set_map by auto
thus ?thesis
using a' j Hom.φ_ψ C.ide_in_hom J.ide_in_hom by blast
qed
finally show "S.Fun (YoD.at a' (map o χ) j ⋅⇩S ?f) e = S.Fun (σ j) e"
by auto
qed
ultimately show "S.Fun (YoD.at a' (map o χ) j ⋅⇩S ?f) e = S.Fun (σ j) e"
by auto
qed
qed
finally show "YoD_a'.cones_map ?f (YoD.at a' (map o χ)) j = σ j" by auto
qed
hence ff: "?f ∈ S.hom x (Hom.map (a', a)) ∧
YoD_a'.cones_map ?f (YoD.at a' (map o χ)) = σ"
using f by auto
text‹
Any other arrow ‹f' ∈ S.hom x (Hom.map (a', a))› that
transforms the cone obtained by evaluating ‹Y o χ› at @{term a'}
to the cone @{term σ}, must equal ‹f›, showing that ‹f›
is unique.
›
moreover have "⋀f'. «f' : x →⇩S Hom.map (a', a)» ∧
YoD_a'.cones_map f' (YoD.at a' (map o χ)) = σ
⟹ f' = ?f"
proof -
fix f'
assume f': "«f' : x →⇩S Hom.map (a', a)» ∧
YoD_a'.cones_map f' (YoD.at a' (map o χ)) = σ"
show "f' = ?f"
proof (intro S.arr_eqI)
show par: "S.par f' ?f" using f f' by (elim S.in_homE, auto)
show "S.Fun f' = S.Fun ?f"
proof
fix e
have "e ∉ S.set x ⟹ S.Fun f' e = S.Fun ?f e"
using f f' x S.Fun_mapsto extensional_arb S.Fun_in_terms_of_comp
by fastforce
moreover have "e ∈ S.set x ⟹ S.Fun f' e = S.Fun ?f e"
proof -
assume e: "e ∈ S.set x"
have fe: "S.Fun ?f e ∈ Hom.set (a', a)"
using e f S.arr_mkArr par by auto
have f'e: "S.Fun f' e ∈ Hom.set (a', a)"
using a a' e f' S.Fun_mapsto Hom.set_map by fastforce
have 1: "«ψ (a', a) (S.Fun f' e) : a' → a»"
using a a' e f' f'e S.Fun_mapsto Hom.ψ_mapsto Hom.set_map by blast
have 2: "«ψ (a', a) (S.Fun ?f e) : a' → a»"
using a a' e f' fe S.Fun_mapsto Hom.ψ_mapsto Hom.set_map by blast
interpret χofe: cone J C D a' ‹D.cones_map (ψ (a', a) (S.Fun ?f e)) χ›
proof -
have "D.cones_map (ψ (a', a) (S.Fun ?f e)) ∈ D.cones a → D.cones a'"
using 2 D.cones_map_mapsto [of "ψ (a', a) (S.Fun ?f e)"]
by (elim C.in_homE, auto)
thus "cone J C D a' (D.cones_map (ψ (a', a) (S.Fun ?f e)) χ)"
using χ.cone_axioms by blast
qed
have A: "⋀h j. h ∈ C.hom a' a ⟹ J.arr j ⟹
S.Fun (YoD.at a' (map o χ) j) (φ (a', a) h)
= φ (a', D (J.cod j)) (χ j ⋅ h)"
proof -
fix h j
assume j: "J.arr j"
assume h: "h ∈ C.hom a' a"
have "S.Fun (YoD.at a' (map o χ) j) (φ (a', a) h)
= (φ (a', D (J.cod j)) ∘ C (χ j) ∘ ψ (a', a)) (φ (a', a) h)"
proof -
have "S.Fun (YoD.at a' (map o χ) j)
= restrict (φ (a', D (J.cod j)) ∘ C (χ j) ∘ ψ (a', a))
(Hom.set (a', a))"
proof -
have "S.Fun (YoD.at a' (map o χ) j) = S.Fun (Y (χ j) a')"
using a' j YoD.at_simp Y_def Yoχ.preserves_reflects_arr [of j]
by simp
also have "... = restrict (φ (a', D (J.cod j)) ∘ C (χ j) ∘ ψ (a', a))
(Hom.set (a', a))"
using a' j χ.preserves_hom [of j "J.dom j" "J.cod j"]
Y_arr_ide [of a' "χ j" a "D (J.cod j)"] χ.A.map_simp S.Fun_mkArr
by fastforce
finally show ?thesis by blast
qed
thus ?thesis
using a a' h Hom.φ_mapsto by auto
qed
also have "... = φ (a', D (J.cod j)) (χ j ⋅ h)"
using a a' h Hom.ψ_φ by simp
finally show "S.Fun (YoD.at a' (map o χ) j) (φ (a', a) h)
= φ (a', D (J.cod j)) (χ j ⋅ h)"
by auto
qed
have "D.cones_map (ψ (a', a) (S.Fun f' e)) χ =
D.cones_map (ψ (a', a) (S.Fun ?f e)) χ"
proof
fix j
have "¬J.arr j ⟹ D.cones_map (ψ (a', a) (S.Fun f' e)) χ j =
D.cones_map (ψ (a', a) (S.Fun ?f e)) χ j"
using 1 2 χ.cone_axioms by (elim C.in_homE, auto)
moreover have "J.arr j ⟹ D.cones_map (ψ (a', a) (S.Fun f' e)) χ j =
D.cones_map (ψ (a', a) (S.Fun ?f e)) χ j"
proof -
assume j: "J.arr j"
have "D.cones_map (ψ (a', a) (S.Fun f' e)) χ j =
χ j ⋅ ψ (a', a) (S.Fun f' e)"
using j 1 χ.cone_axioms by auto
also have "... = ψ (a', D (J.cod j)) (S.Fun (σ j) e)"
proof -
have "ψ (a', D (J.cod j)) (S.Fun (YoD.at a' (map o χ) j) (S.Fun f' e)) =
ψ (a', D (J.cod j))
(φ (a', D (J.cod j)) (χ j ⋅ ψ (a', a) (S.Fun f' e)))"
using j a a' f'e A Hom.φ_ψ Hom.ψ_mapsto by force
moreover have "χ j ⋅ ψ (a', a) (S.Fun f' e) ∈ C.hom a' (D (J.cod j))"
using a a' j f'e Hom.ψ_mapsto χ.preserves_hom [of j "J.dom j" "J.cod j"]
χ.A.map_simp
by auto
moreover have "S.Fun (YoD.at a' (map o χ) j) (S.Fun f' e) =
S.Fun (σ j) e"
using Fun_map_a_a' a a' j f' e x Yoχ_a'.A.map_simp eval_at_ide
Yoχ_a'.cone_axioms
by auto
ultimately show ?thesis
using a a' Hom.ψ_φ by auto
qed
also have "... = χ j ⋅ ψ (a', a) (S.Fun ?f e)"
proof -
have "S.Fun (YoD.at a' (map o χ) j) (S.Fun ?f e) =
φ (a', D (J.cod j)) (χ j ⋅ ψ (a', a) (S.Fun ?f e))"
using j a a' fe A [of "ψ (a', a) (S.Fun ?f e)" j] Hom.φ_ψ Hom.ψ_mapsto
by auto
hence "ψ (a', D (J.cod j)) (S.Fun (YoD.at a' (map o χ) j) (S.Fun ?f e)) =
ψ (a', D (J.cod j))
(φ (a', D (J.cod j)) (χ j ⋅ ψ (a', a) (S.Fun ?f e)))"
by simp
moreover have "χ j ⋅ ψ (a', a) (S.Fun ?f e) ∈ C.hom a' (D (J.cod j))"
using a a' j fe Hom.ψ_mapsto χ.preserves_hom [of j "J.dom j" "J.cod j"]
χ.A.map_simp
by auto
moreover have "S.Fun (YoD.at a' (map o χ) j) (S.Fun ?f e) =
S.Fun (σ j) e"
proof -
have "S.Fun (YoD.at a' (map o χ) j) (S.Fun ?f e)
= (S.Fun (YoD.at a' (map o χ) j) o S.Fun ?f) e"
by simp
also have "... = S.Fun (YoD.at a' (map o χ) j ⋅⇩S ?f) e"
using Fun_map_a_a' a a' j f e x Yoχ_a'.A.map_simp eval_at_ide
by auto
also have "... = S.Fun (σ j) e"
proof -
have "YoD.at a' (map o χ) j ⋅⇩S ?f =
YoD_a'.cones_map ?f (YoD.at a' (map o χ)) j"
using j f Yoχ_a'.cone_axioms Fun_map_a_a' by auto
thus ?thesis using j ff by argo
qed
finally show ?thesis by auto
qed
ultimately show ?thesis
using a a' Hom.ψ_φ by auto
qed
also have "... = D.cones_map (ψ (a', a) (S.Fun ?f e)) χ j"
using j 2 χ.cone_axioms by force
finally show "D.cones_map (ψ (a', a) (S.Fun f' e)) χ j =
D.cones_map (ψ (a', a) (S.Fun ?f e)) χ j"
by auto
qed
ultimately show "D.cones_map (ψ (a', a) (S.Fun f' e)) χ j =
D.cones_map (ψ (a', a) (S.Fun ?f e)) χ j"
by auto
qed
hence "ψ (a', a) (S.Fun f' e) = ψ (a', a) (S.Fun ?f e)"
using 1 2 χofe.cone_axioms χ.cone_axioms χ.is_universal by blast
hence "φ (a', a) (ψ (a', a) (S.Fun f' e)) = φ (a', a) (ψ (a', a) (S.Fun ?f e))"
by simp
thus "S.Fun f' e = S.Fun ?f e"
using a a' fe f'e Hom.φ_ψ by force
qed
ultimately show "S.Fun f' e = S.Fun ?f e" by auto
qed
qed
qed
ultimately have "∃!f. «f : x →⇩S Hom.map (a', a)» ∧
YoD_a'.cones_map f (YoD.at a' (map o χ)) = σ"
using ex1I [of "λf. S.in_hom x (Hom.map (a', a)) f ∧
YoD_a'.cones_map f (YoD.at a' (map o χ)) = σ"]
by blast
thus "∃!f. «f : x →⇩S Cop_S.Map (map a) a'» ∧
YoD_a'.cones_map f (YoD.at a' (map o χ)) = σ"
using a a' Y_def by simp
qed
qed
thus "YoD.has_as_limit (map a)"
using YoD.cone_is_limit_if_pointwise_limit Yoχ.cone_axioms by auto
qed
end
end
Theory Subcategory
chapter "Subcategory"
text‹
In this chapter we give a construction of the subcategory of a category
defined by a predicate on arrows subject to closure conditions. The arrows of
the subcategory are directly identified with the arrows of the ambient category.
We also define the related notions of full subcategory and inclusion functor.
›
theory Subcategory
imports Functor
begin
locale subcategory =
C: category C
for C :: "'a comp" (infixr "⋅⇩C" 55)
and Arr :: "'a ⇒ bool" +
assumes inclusion: "Arr f ⟹ C.arr f"
and dom_closed: "Arr f ⟹ Arr (C.dom f)"
and cod_closed: "Arr f ⟹ Arr (C.cod f)"
and comp_closed: "⟦ Arr f; Arr g; C.cod f = C.dom g ⟧ ⟹ Arr (g ⋅⇩C f)"
begin
no_notation C.in_hom ("«_ : _ → _»")
notation C.in_hom ("«_ : _ →⇩C _»")
definition comp (infixr "⋅" 55)
where "g ⋅ f = (if Arr f ∧ Arr g ∧ C.cod f = C.dom g then g ⋅⇩C f else C.null)"
interpretation partial_magma comp
proof
show "∃!n. ∀f. n ⋅ f = n ∧ f ⋅ n = n"
proof
show 1: "∀f. C.null ⋅ f = C.null ∧ f ⋅ C.null = C.null"
by (metis C.comp_null(1) C.ex_un_null comp_def)
show "⋀n. ∀f. n ⋅ f = n ∧ f ⋅ n = n ⟹ n = C.null"
using 1 C.ex_un_null by metis
qed
qed
lemma null_char [simp]:
shows "null = C.null"
proof -
have "∀f. C.null ⋅ f = C.null ∧ f ⋅ C.null = C.null"
by (metis C.comp_null(1) C.ex_un_null comp_def)
thus ?thesis using ex_un_null by (metis comp_null(2))
qed
lemma ideI:
assumes "Arr a" and "C.ide a"
shows "ide a"
unfolding ide_def
using assms null_char C.ide_def comp_def by auto
lemma Arr_iff_dom_in_domain:
shows "Arr f ⟷ C.dom f ∈ domains f"
proof
show "C.dom f ∈ domains f ⟹ Arr f"
using domains_def comp_def ide_def by fastforce
show "Arr f ⟹ C.dom f ∈ domains f"
proof -
assume f: "Arr f"
have "ide (C.dom f)"
using f inclusion C.dom_in_domains C.has_domain_iff_arr C.domains_def
dom_closed ideI
by auto
moreover have "f ⋅ C.dom f ≠ null"
using f comp_def dom_closed null_char inclusion C.comp_arr_dom by force
ultimately show ?thesis
using domains_def by simp
qed
qed
lemma Arr_iff_cod_in_codomain:
shows "Arr f ⟷ C.cod f ∈ codomains f"
proof
show "C.cod f ∈ codomains f ⟹ Arr f"
using codomains_def comp_def ide_def by fastforce
show "Arr f ⟹ C.cod f ∈ codomains f"
proof -
assume f: "Arr f"
have "ide (C.cod f)"
using f inclusion C.cod_in_codomains C.has_codomain_iff_arr C.codomains_def
cod_closed ideI
by auto
moreover have "C.cod f ⋅ f ≠ null"
using f comp_def cod_closed null_char inclusion C.comp_cod_arr by force
ultimately show ?thesis
using codomains_def by simp
qed
qed
lemma arr_char:
shows "arr f ⟷ Arr f"
proof
show "Arr f ⟹ arr f"
using arr_def comp_def Arr_iff_dom_in_domain Arr_iff_cod_in_codomain by auto
show "arr f ⟹ Arr f"
proof -
assume f: "arr f"
obtain a where a: "a ∈ domains f ∨ a ∈ codomains f"
using f arr_def by auto
have "f ⋅ a ≠ C.null ∨ a ⋅ f ≠ C.null"
using a domains_def codomains_def null_char by auto
thus "Arr f"
using comp_def by metis
qed
qed
lemma arrI [intro]:
assumes "Arr f"
shows "arr f"
using assms arr_char by simp
lemma arrE [elim]:
assumes "arr f"
shows "Arr f"
using assms arr_char by simp
interpretation category comp
using comp_def null_char inclusion comp_closed dom_closed cod_closed
apply unfold_locales
apply auto[1]
apply (metis Arr_iff_dom_in_domain Arr_iff_cod_in_codomain arr_char arr_def emptyE)
proof -
fix f g h
assume gf: "seq g f" and hg: "seq h g"
show 1: "seq (h ⋅ g) f"
using gf hg inclusion comp_closed comp_def by auto
show "(h ⋅ g) ⋅ f = h ⋅ g ⋅ f"
using gf hg 1 C.not_arr_null inclusion comp_def arr_char
by (metis (full_types) C.cod_comp C.comp_assoc)
next
fix f g h
assume hg: "seq h g" and hgf: "seq (h ⋅ g) f"
show "seq g f"
using hg hgf comp_def null_char inclusion arr_char comp_closed
by (metis (full_types) C.dom_comp)
next
fix f g h
assume hgf: "seq h (g ⋅ f)" and gf: "seq g f"
show "seq h g"
using hgf gf comp_def null_char arr_char comp_closed
by (metis C.seqE C.ext C.match_2)
qed
theorem is_category:
shows "category comp" ..
notation in_hom ("«_ : _ → _»")
lemma dom_simp:
assumes "arr f"
shows "dom f = C.dom f"
proof -
have "ide (C.dom f)"
using assms ideI
by (meson C.ide_dom arr_char dom_closed inclusion)
moreover have "f ⋅ C.dom f ≠ null"
using assms inclusion comp_def null_char dom_closed not_arr_null C.comp_arr_dom arr_char
by auto
ultimately show ?thesis
using dom_eqI ext by blast
qed
lemma dom_char:
shows "dom f = (if arr f then C.dom f else C.null)"
using dom_simp dom_def arr_def arr_char by auto
lemma cod_simp:
assumes "arr f"
shows "cod f = C.cod f"
proof -
have "ide (C.cod f)"
using assms ideI
by (meson C.ide_cod arr_char cod_closed inclusion)
moreover have "C.cod f ⋅ f ≠ null"
using assms inclusion comp_def null_char cod_closed not_arr_null C.comp_cod_arr arr_char
by auto
ultimately show ?thesis
using cod_eqI ext by blast
qed
lemma cod_char:
shows "cod f = (if arr f then C.cod f else C.null)"
using cod_simp cod_def arr_def by auto
lemma in_hom_char:
shows "«f : a → b» ⟷ arr a ∧ arr b ∧ arr f ∧ «f : a →⇩C b»"
using inclusion arr_char cod_closed dom_closed
by (metis C.arr_iff_in_hom C.in_homE arr_iff_in_hom cod_simp dom_simp in_homE)
lemma ide_char:
shows "ide a ⟷ arr a ∧ C.ide a"
using ide_in_hom C.ide_in_hom in_hom_char by simp
lemma seq_char:
shows "seq g f ⟷ arr f ∧ arr g ∧ C.seq g f"
proof
show "arr f ∧ arr g ∧ C.seq g f ⟹ seq g f"
using arr_char dom_char cod_char by (intro seqI, auto)
show "seq g f ⟹ arr f ∧ arr g ∧ C.seq g f"
apply (elim seqE, auto)
using inclusion arr_char dom_simp cod_simp by auto
qed
lemma hom_char:
shows "hom a b = C.hom a b ∩ Collect Arr"
proof
show "hom a b ⊆ C.hom a b ∩ Collect Arr"
using in_hom_char by auto
show "C.hom a b ∩ Collect Arr ⊆ hom a b"
using arr_char dom_char cod_char by force
qed
lemma comp_char:
shows "g ⋅ f = (if arr f ∧ arr g ∧ C.seq g f then g ⋅⇩C f else C.null)"
using arr_char comp_def comp_closed C.ext by force
lemma comp_simp:
assumes "seq g f"
shows "g ⋅ f = g ⋅⇩C f"
using assms comp_char seq_char by metis
lemma inclusion_preserves_inverse:
assumes "inverse_arrows f g"
shows "C.inverse_arrows f g"
using assms ide_char comp_simp arr_char
by (intro C.inverse_arrowsI, auto)
lemma iso_char:
shows "iso f ⟷ C.iso f ∧ arr f ∧ arr (C.inv f)"
proof
assume f: "iso f"
show "C.iso f ∧ arr f ∧ arr (C.inv f)"
proof -
have 1: "inverse_arrows f (inv f)"
using f inv_is_inverse by auto
have 2: "C.inverse_arrows f (inv f)"
using 1 inclusion_preserves_inverse by blast
moreover have "arr (inv f)"
using 1 iso_is_arr by blast
moreover have "inv f = C.inv f"
using 1 2 C.inv_is_inverse C.inverse_arrow_unique by blast
ultimately show ?thesis using f 2 iso_is_arr by auto
qed
next
assume f: "C.iso f ∧ arr f ∧ arr (C.inv f)"
show "iso f"
proof
have 1: "C.inverse_arrows f (C.inv f)"
using f C.inv_is_inverse by blast
show "inverse_arrows f (C.inv f)"
proof
have 2: "C.inv f ⋅ f = C.inv f ⋅⇩C f ∧ f ⋅ C.inv f = f ⋅⇩C C.inv f"
using f 1 comp_char by fastforce
have 3: "antipar f (C.inv f)"
using f C.seqE seqI dom_simp cod_simp by simp
show "ide (C.inv f ⋅ f)"
using 1 2 3 ide_char apply (elim C.inverse_arrowsE) by simp
show "ide (f ⋅ C.inv f)"
using 1 2 3 ide_char apply (elim C.inverse_arrowsE) by simp
qed
qed
qed
lemma inv_char:
assumes "iso f"
shows "inv f = C.inv f"
proof -
have "C.inverse_arrows f (inv f)"
proof
have 1: "inverse_arrows f (inv f)"
using assms iso_char inv_is_inverse by blast
show "C.ide (inv f ⋅⇩C f)"
proof -
have "inv f ⋅ f = inv f ⋅⇩C f"
using assms 1 inv_in_hom iso_char [of f] comp_char [of "inv f" f] seq_char by auto
thus ?thesis
using 1 ide_char arr_char by force
qed
show "C.ide (f ⋅⇩C inv f)"
proof -
have "f ⋅ inv f = f ⋅⇩C inv f"
using assms 1 inv_in_hom iso_char [of f] comp_char [of f "inv f"] seq_char by auto
thus ?thesis
using 1 ide_char arr_char by force
qed
qed
thus ?thesis using C.inverse_arrow_unique C.inv_is_inverse by blast
qed
end
sublocale subcategory ⊆ category comp
using is_category by auto
section "Full Subcategory"
locale full_subcategory =
C: category C
for C :: "'a comp"
and Ide :: "'a ⇒ bool" +
assumes inclusion: "Ide f ⟹ C.ide f"
sublocale full_subcategory ⊆ subcategory C "λf. C.arr f ∧ Ide (C.dom f) ∧ Ide (C.cod f)"
by (unfold_locales; simp)
context full_subcategory
begin
text ‹
Isomorphisms in a full subcategory are inherited from the ambient category.
›
lemma iso_char:
shows "iso f ⟷ arr f ∧ C.iso f"
proof
assume f: "iso f"
obtain g where g: "inverse_arrows f g" using f by blast
show "arr f ∧ C.iso f"
proof -
have "C.inverse_arrows f g"
using g apply (elim inverse_arrowsE, intro C.inverse_arrowsI)
using comp_simp ide_char arr_char by auto
thus ?thesis
using f iso_is_arr by blast
qed
next
assume f: "arr f ∧ C.iso f"
obtain g where g: "C.inverse_arrows f g" using f by blast
have "inverse_arrows f g"
proof
show "ide (comp g f)"
using f g
by (metis (no_types, lifting) C.seqE C.ide_compE C.inverse_arrowsE
arr_char dom_simp ide_dom comp_def)
show "ide (comp f g)"
using f g C.inverse_arrows_sym [of f g]
by (metis (no_types, lifting) C.seqE C.ide_compE C.inverse_arrowsE
arr_char dom_simp ide_dom comp_def)
qed
thus "iso f" by auto
qed
end
section "Inclusion Functor"
text ‹
If ‹S› is a subcategory of ‹C›, then there is an inclusion functor
from ‹S› to ‹C›. Inclusion functors are faithful embeddings.
›
locale inclusion_functor =
C: category C +
S: subcategory C Arr
for C :: "'a comp"
and Arr :: "'a ⇒ bool"
begin
interpretation "functor" S.comp C S.map
using S.map_def S.arr_char S.inclusion S.dom_char S.cod_char
S.dom_closed S.cod_closed S.comp_closed S.arr_char S.comp_char
apply unfold_locales
apply auto[4]
by (elim S.seqE, auto)
lemma is_functor:
shows "functor S.comp C S.map" ..
interpretation faithful_functor S.comp C S.map
apply unfold_locales by simp
lemma is_faithful_functor:
shows "faithful_functor S.comp C S.map" ..
interpretation embedding_functor S.comp C S.map
apply unfold_locales by simp
lemma is_embedding_functor:
shows "embedding_functor S.comp C S.map" ..
end
sublocale inclusion_functor ⊆ faithful_functor S.comp C S.map
using is_faithful_functor by auto
sublocale inclusion_functor ⊆ embedding_functor S.comp C S.map
using is_embedding_functor by auto
text ‹
The inclusion of a full subcategory is a special case.
Such functors are fully faithful.
›
locale full_inclusion_functor =
C: category C +
S: full_subcategory C Ide
for C :: "'a comp"
and Ide :: "'a ⇒ bool"
sublocale full_inclusion_functor ⊆
inclusion_functor C "λf. C.arr f ∧ Ide (C.dom f) ∧ Ide (C.cod f)" ..
context full_inclusion_functor
begin
interpretation full_functor S.comp C S.map
apply unfold_locales
using S.ide_in_hom
by (metis (no_types, lifting) C.in_homE S.arr_char S.in_hom_char S.map_simp)
lemma is_full_functor:
shows "full_functor S.comp C S.map" ..
end
sublocale full_inclusion_functor ⊆ full_functor S.comp C S.map
using is_full_functor by auto
sublocale full_inclusion_functor ⊆ fully_faithful_functor S.comp C S.map ..
end
Theory EquivalenceOfCategories
chapter "Equivalence of Categories"
text ‹
In this chapter we define the notions of equivalence and adjoint equivalence of categories
and establish some properties of functors that are part of an equivalence.
›
theory EquivalenceOfCategories
imports Adjunction
begin
locale equivalence_of_categories =
C: category C +
D: category D +
F: "functor" D C F +
G: "functor" C D G +
η: natural_isomorphism D D D.map "G o F" η +
ε: natural_isomorphism C C "F o G" C.map ε
for C :: "'c comp" (infixr "⋅⇩C" 55)
and D :: "'d comp" (infixr "⋅⇩D" 55)
and F :: "'d ⇒ 'c"
and G :: "'c ⇒ 'd"
and η :: "'d ⇒ 'd"
and ε :: "'c ⇒ 'c"
begin
notation C.in_hom ("«_ : _ →⇩C _»")
notation D.in_hom ("«_ : _ →⇩D _»")
lemma C_arr_expansion:
assumes "C.arr f"
shows "ε (C.cod f) ⋅⇩C F (G f) ⋅⇩C C.inv (ε (C.dom f)) = f"
and "C.inv (ε (C.cod f)) ⋅⇩C f ⋅⇩C ε (C.dom f) = F (G f)"
proof -
have ε_dom: "C.inverse_arrows (ε (C.dom f)) (C.inv (ε (C.dom f)))"
using assms C.inv_is_inverse by auto
have ε_cod: "C.inverse_arrows (ε (C.cod f)) (C.inv (ε (C.cod f)))"
using assms C.inv_is_inverse by auto
have "ε (C.cod f) ⋅⇩C F (G f) ⋅⇩C C.inv (ε (C.dom f)) =
(ε (C.cod f) ⋅⇩C F (G f)) ⋅⇩C C.inv (ε (C.dom f))"
using C.comp_assoc by force
also have 1: "... = (f ⋅⇩C ε (C.dom f)) ⋅⇩C C.inv (ε (C.dom f))"
using assms ε.naturality by simp
also have 2: "... = f"
using assms ε_dom C.comp_arr_inv C.comp_arr_dom C.comp_assoc by force
finally show "ε (C.cod f) ⋅⇩C F (G f) ⋅⇩C C.inv (ε (C.dom f)) = f" by blast
show "C.inv (ε (C.cod f)) ⋅⇩C f ⋅⇩C ε (C.dom f) = F (G f)"
using assms 1 2 ε_dom ε_cod C.invert_side_of_triangle C.isoI C.iso_inv_iso
by metis
qed
lemma G_is_faithful:
shows "faithful_functor C D G"
proof
fix f f'
assume par: "C.par f f'" and eq: "G f = G f'"
show "f = f'"
proof -
have "C.inv (ε (C.cod f)) ∈ C.hom (C.cod f) (F (G (C.cod f))) ∧
C.iso (C.inv (ε (C.cod f)))"
using par by auto
moreover have 1: "ε (C.dom f) ∈ C.hom (F (G (C.dom f))) (C.dom f) ∧
C.iso (ε (C.dom f))"
using par by auto
ultimately have 2: "f ⋅⇩C ε (C.dom f) = f' ⋅⇩C ε (C.dom f)"
using par C_arr_expansion eq C.iso_is_section C.section_is_mono
by (metis C_arr_expansion(1) eq)
show ?thesis
proof -
have "C.epi (ε (C.dom f))"
using 1 par C.iso_is_retraction C.retraction_is_epi by blast
thus ?thesis using 2 par by auto
qed
qed
qed
lemma G_is_essentially_surjective:
shows "essentially_surjective_functor C D G"
proof
fix b
assume b: "D.ide b"
have "C.ide (F b) ∧ D.isomorphic (G (F b)) b"
proof
show "C.ide (F b)" using b by simp
show "D.isomorphic (G (F b)) b"
proof (unfold D.isomorphic_def)
have "«D.inv (η b) : G (F b) →⇩D b» ∧ D.iso (D.inv (η b))"
using b by auto
thus "∃f. «f : G (F b) →⇩D b» ∧ D.iso f" by blast
qed
qed
thus "∃a. C.ide a ∧ D.isomorphic (G a) b"
by blast
qed
interpretation ε_inv: inverse_transformation C C ‹F o G› C.map ε ..
interpretation η_inv: inverse_transformation D D D.map ‹G o F› η ..
interpretation GF: equivalence_of_categories D C G F ε_inv.map η_inv.map ..
lemma F_is_faithful:
shows "faithful_functor D C F"
using GF.G_is_faithful by simp
lemma F_is_essentially_surjective:
shows "essentially_surjective_functor D C F"
using GF.G_is_essentially_surjective by simp
lemma G_is_full:
shows "full_functor C D G"
proof
fix a a' g
assume a: "C.ide a" and a': "C.ide a'"
assume g: "«g : G a →⇩D G a'»"
show "∃f. «f : a →⇩C a'» ∧ G f = g"
proof
have εa: "C.inverse_arrows (ε a) (C.inv (ε a))"
using a C.inv_is_inverse by auto
have εa': "C.inverse_arrows (ε a') (C.inv (ε a'))"
using a' C.inv_is_inverse by auto
let ?f = "ε a' ⋅⇩C F g ⋅⇩C C.inv (ε a)"
have f: "«?f : a →⇩C a'»"
using a a' g εa εa' ε.preserves_hom [of a' a' a'] ε_inv.preserves_hom [of a a a]
by fastforce
moreover have "G ?f = g"
proof -
interpret F: faithful_functor D C F
using F_is_faithful by auto
have "F (G ?f) = F g"
proof -
have "F (G ?f) = C.inv (ε a') ⋅⇩C ?f ⋅⇩C ε a"
using f C_arr_expansion(2) [of "?f"] by auto
also have "... = (C.inv (ε a') ⋅⇩C ε a') ⋅⇩C F g ⋅⇩C C.inv (ε a) ⋅⇩C ε a"
using a a' f g C.comp_assoc by fastforce
also have "... = F g"
using a a' g εa εa' C.comp_inv_arr C.comp_arr_dom C.comp_cod_arr by auto
finally show ?thesis by blast
qed
moreover have "D.par (G (ε a' ⋅⇩C F g ⋅⇩C C.inv (ε a))) g"
using f g by fastforce
ultimately show ?thesis using f g F.is_faithful by blast
qed
ultimately show "«?f : a →⇩C a'» ∧ G ?f = g" by blast
qed
qed
end
context equivalence_of_categories
begin
interpretation ε_inv: inverse_transformation C C ‹F o G› C.map ε ..
interpretation η_inv: inverse_transformation D D D.map ‹G o F› η ..
interpretation GF: equivalence_of_categories D C G F ε_inv.map η_inv.map ..
lemma F_is_full:
shows "full_functor D C F"
using GF.G_is_full by simp
end
text ‹
Traditionally the term "equivalence of categories" is also used for a functor
that is part of an equivalence of categories. However, it seems best to use
that term for a situation in which all of the structure of an equivalence is
explicitly given, and to have a different term for one of the functors involved.
›
locale equivalence_functor =
C: category C +
D: category D +
"functor" C D G
for C :: "'c comp" (infixr "⋅⇩C" 55)
and D :: "'d comp" (infixr "⋅⇩D" 55)
and G :: "'c ⇒ 'd" +
assumes induces_equivalence: "∃F η ε. equivalence_of_categories C D F G η ε"
begin
notation C.in_hom ("«_ : _ →⇩C _»")
notation D.in_hom ("«_ : _ →⇩D _»")
end
sublocale equivalence_of_categories ⊆ equivalence_functor C D G
using equivalence_of_categories_axioms by (unfold_locales, blast)
text ‹
An equivalence functor is fully faithful and essentially surjective.
›
sublocale equivalence_functor ⊆ fully_faithful_functor C D G
proof -
obtain F η ε where 1: "equivalence_of_categories C D F G η ε"
using induces_equivalence by blast
interpret equivalence_of_categories C D F G η ε
using 1 by auto
show "fully_faithful_functor C D G"
using G_is_full G_is_faithful fully_faithful_functor.intro by auto
qed
sublocale equivalence_functor ⊆ essentially_surjective_functor C D G
proof -
obtain F η ε where 1: "equivalence_of_categories C D F G η ε"
using induces_equivalence by blast
interpret equivalence_of_categories C D F G η ε
using 1 by auto
show "essentially_surjective_functor C D G"
using G_is_essentially_surjective by auto
qed
text ‹
A special case of an equivalence functor is an endofunctor ‹F› equipped with
a natural isomorphism from ‹F› to the identity functor.
›
context endofunctor
begin
lemma isomorphic_to_identity_is_equivalence:
assumes "natural_isomorphism A A F A.map φ"
shows "equivalence_functor A A F"
proof -
interpret φ: natural_isomorphism A A F A.map φ
using assms by auto
interpret φ': inverse_transformation A A F A.map φ ..
interpret Fφ': natural_isomorphism A A F ‹F o F› ‹F o φ'.map›
proof -
interpret Fφ': natural_transformation A A F ‹F o F› ‹F o φ'.map›
using φ'.natural_transformation_axioms functor_axioms
horizontal_composite [of A A A.map F φ'.map A F F F]
by simp
show "natural_isomorphism A A F (F o F) (F o φ'.map)"
apply unfold_locales
using φ'.components_are_iso by fastforce
qed
interpret Fφ'oφ': vertical_composite A A A.map F ‹F o F› φ'.map ‹F o φ'.map› ..
interpret Fφ'oφ': natural_isomorphism A A A.map ‹F o F› Fφ'oφ'.map
using φ'.natural_isomorphism_axioms Fφ'.natural_isomorphism_axioms
natural_isomorphisms_compose
by fast
interpret inv_Fφ'oφ': inverse_transformation A A A.map ‹F o F› Fφ'oφ'.map ..
interpret F: equivalence_of_categories A A F F Fφ'oφ'.map inv_Fφ'oφ'.map ..
show ?thesis ..
qed
end
text ‹
An adjoint equivalence is an equivalence of categories that is also an adjunction.
›
locale adjoint_equivalence =
unit_counit_adjunction C D F G η ε +
η: natural_isomorphism D D D.map "G o F" η +
ε: natural_isomorphism C C "F o G" C.map ε
for C :: "'c comp" (infixr "⋅⇩C" 55)
and D :: "'d comp" (infixr "⋅⇩D" 55)
and F :: "'d ⇒ 'c"
and G :: "'c ⇒ 'd"
and η :: "'d ⇒ 'd"
and ε :: "'c ⇒ 'c"
text ‹
An adjoint equivalence is clearly an equivalence of categories.
›
sublocale adjoint_equivalence ⊆ equivalence_of_categories ..
context adjoint_equivalence
begin
text ‹
The triangle identities for an adjunction reduce to inverse relations when
‹η› and ‹ε› are natural isomorphisms.
›
lemma triangle_G':
assumes "C.ide a"
shows "D.inverse_arrows (η (G a)) (G (ε a))"
proof
show "D.ide (G (ε a) ⋅⇩D η (G a))"
using assms triangle_G GεoηG.map_simp_ide by fastforce
thus "D.ide (η (G a) ⋅⇩D G (ε a))"
using assms D.section_retraction_of_iso [of "G (ε a)" "η (G a)"] by auto
qed
lemma triangle_F':
assumes "D.ide b"
shows "C.inverse_arrows (F (η b)) (ε (F b))"
proof
show "C.ide (ε (F b) ⋅⇩C F (η b))"
using assms triangle_F εFoFη.map_simp_ide by auto
thus "C.ide (F (η b) ⋅⇩C ε (F b))"
using assms C.section_retraction_of_iso [of "ε (F b)" "F (η b)"] by auto
qed
text ‹
An adjoint equivalence can be dualized by interchanging the two functors and inverting
the natural isomorphisms. This is somewhat awkward to prove, but probably useful to have
done it once and for all.
›
lemma dual_equivalence:
assumes "adjoint_equivalence C D F G η ε"
shows "adjoint_equivalence D C G F (inverse_transformation.map C C (C.map) ε)
(inverse_transformation.map D D (G o F) η)"
proof -
interpret adjoint_equivalence C D F G η ε using assms by auto
interpret ε': inverse_transformation C C ‹F o G› C.map ε ..
interpret η': inverse_transformation D D D.map ‹G o F› η ..
interpret Gε': natural_transformation C D G ‹G o F o G› ‹G o ε'.map›
proof -
have "natural_transformation C D G (G o (F o G)) (G o ε'.map)"
using G.natural_transformation_axioms ε'.natural_transformation_axioms
horizontal_composite
by fastforce
thus "natural_transformation C D G (G o F o G) (G o ε'.map)"
using o_assoc by metis
qed
interpret η'G: natural_transformation C D ‹G o F o G› G ‹η'.map o G›
using η'.natural_transformation_axioms G.natural_transformation_axioms
horizontal_composite
by fastforce
interpret ε'F: natural_transformation D C F ‹F o G o F› ‹ε'.map o F›
using ε'.natural_transformation_axioms F.natural_transformation_axioms
horizontal_composite
by fastforce
interpret Fη': natural_transformation D C ‹F o G o F› F ‹F o η'.map›
proof -
have "natural_transformation D C (F o (G o F)) F (F o η'.map)"
using η'.natural_transformation_axioms F.natural_transformation_axioms
horizontal_composite
by fastforce
thus "natural_transformation D C (F o G o F) F (F o η'.map)"
using o_assoc by metis
qed
interpret Fη'oε'F: vertical_composite D C F ‹(F o G) o F› F ‹ε'.map o F› ‹F o η'.map› ..
interpret η'GoGε': vertical_composite C D G ‹G o F o G› G ‹G o ε'.map› ‹η'.map o G› ..
show ?thesis
proof
show "η'GoGε'.map = G"
proof (intro NaturalTransformation.eqI)
show "natural_transformation C D G G G"
using G.natural_transformation_axioms by auto
show "natural_transformation C D G G η'GoGε'.map"
using η'GoGε'.natural_transformation_axioms by auto
show "⋀a. C.ide a ⟹ η'GoGε'.map a = G a"
proof -
fix a
assume a: "C.ide a"
show "η'GoGε'.map a = G a"
using a η'GoGε'.map_simp_ide triangle_G'
η.components_are_iso ε.components_are_iso G.preserves_ide
η'.inverts_components ε'.inverts_components
D.inverse_unique G.preserves_inverse_arrows GεoηG.map_simp_ide
D.inverse_arrows_sym triangle_G
by (metis o_apply)
qed
qed
show "Fη'oε'F.map = F"
proof (intro NaturalTransformation.eqI)
show "natural_transformation D C F F F"
using F.natural_transformation_axioms by auto
show "natural_transformation D C F F Fη'oε'F.map"
using Fη'oε'F.natural_transformation_axioms by auto
show "⋀b. D.ide b ⟹ Fη'oε'F.map b = F b"
proof -
fix b
assume b: "D.ide b"
show "Fη'oε'F.map b = F b"
using b Fη'oε'F.map_simp_ide εFoFη.map_simp_ide triangle_F triangle_F'
η.components_are_iso ε.components_are_iso G.preserves_ide
η'.inverts_components ε'.inverts_components F.preserves_ide
C.inverse_unique F.preserves_inverse_arrows C.inverse_arrows_sym
by (metis o_apply)
qed
qed
qed
qed
end
text ‹
Every fully faithful and essentially surjective functor underlies an adjoint equivalence.
To prove this without repeating things that were already proved in @{theory Category3.Adjunction},
we first show that a fully faithful and essentially surjective functor is a left adjoint
functor, and then we show that if the left adjoint in a unit-counit adjunction is
fully faithful and essentially surjective, then the unit and counit are natural isomorphisms;
hence the adjunction is in fact an adjoint equivalence.
›
locale fully_faithful_and_essentially_surjective_functor =
C: category C +
D: category D +
fully_faithful_functor C D F +
essentially_surjective_functor C D F
for C :: "'c comp" (infixr "⋅⇩C" 55)
and D :: "'d comp" (infixr "⋅⇩D" 55)
and F :: "'c ⇒ 'd"
begin
notation C.in_hom ("«_ : _ →⇩C _»")
notation D.in_hom ("«_ : _ →⇩D _»")
lemma is_left_adjoint_functor:
shows "left_adjoint_functor C D F"
proof
fix y
assume y: "D.ide y"
let ?x = "SOME x. C.ide x ∧ (∃e. D.iso e ∧ «e : F x →⇩D y»)"
let ?e = "SOME e. D.iso e ∧ «e : F ?x →⇩D y»"
have "∃x e. D.iso e ∧ terminal_arrow_from_functor C D F x y e"
proof -
have "∃x. D.iso ?e ∧ terminal_arrow_from_functor C D F x y ?e"
proof -
have x: "C.ide ?x ∧ (∃e. D.iso e ∧ «e : F ?x →⇩D y»)"
using y essentially_surjective
someI_ex [of "λx. C.ide x ∧ (∃e. D.iso e ∧ «e : F x →⇩D y»)"]
by blast
hence e: "D.iso ?e ∧ «?e : F ?x →⇩D y»"
using someI_ex [of "λe. D.iso e ∧ «e : F ?x →⇩D y»"] by blast
interpret arrow_from_functor C D F ?x y ?e
using x e by (unfold_locales, simp)
interpret terminal_arrow_from_functor C D F ?x y ?e
proof
fix x' f
assume 1: "arrow_from_functor C D F x' y f"
interpret f: arrow_from_functor C D F x' y f
using 1 by simp
have f: "«f: F x' →⇩D y»"
by (meson f.arrow)
show "∃!g. is_coext x' f g"
proof
let ?g = "SOME g. «g : x' →⇩C ?x» ∧ F g = D.inv ?e ⋅⇩D f"
have g: "«?g : x' →⇩C ?x» ∧ F ?g = D.inv ?e ⋅⇩D f"
using f e x f.arrow is_full D.comp_in_homI D.inv_in_hom
someI_ex [of "λg. «g : x' →⇩C ?x» ∧ F g = D.inv ?e ⋅⇩D f"]
by auto
show 1: "is_coext x' f ?g"
proof -
have "«?g : x' →⇩C ?x»"
using g by simp
moreover have "?e ⋅⇩D F ?g = f"
proof -
have "?e ⋅⇩D F ?g = ?e ⋅⇩D D.inv ?e ⋅⇩D f"
using g by simp
also have "... = (?e ⋅⇩D D.inv ?e) ⋅⇩D f"
using e f D.inv_in_hom by (metis D.comp_assoc)
also have "... = f"
proof -
have "?e ⋅⇩D D.inv ?e = y"
using e D.comp_arr_inv D.inv_is_inverse by auto
thus ?thesis
using f D.comp_cod_arr by auto
qed
finally show ?thesis by blast
qed
ultimately show ?thesis
unfolding is_coext_def by simp
qed
show "⋀g'. is_coext x' f g' ⟹ g' = ?g"
proof -
fix g'
assume g': "is_coext x' f g'"
have 2: "«g' : x' →⇩C ?x» ∧ ?e ⋅⇩D F g' = f" using g' is_coext_def by simp
have 3: "«?g : x' →⇩C ?x» ∧ ?e ⋅⇩D F ?g = f" using 1 is_coext_def by simp
have "F g' = F ?g"
using e 2 3 D.iso_is_section D.section_is_mono D.monoE by blast
moreover have "C.par g' ?g"
using 2 3 by fastforce
ultimately show "g' = ?g"
using is_faithful [of g' ?g] by simp
qed
qed
qed
show ?thesis
using e terminal_arrow_from_functor_axioms by auto
qed
thus ?thesis by auto
qed
thus "∃x e. terminal_arrow_from_functor C D F x y e" by blast
qed
lemma extends_to_adjoint_equivalence:
shows "∃G η ε. adjoint_equivalence C D G F η ε"
proof -
interpret left_adjoint_functor C D F
using is_left_adjoint_functor by blast
interpret Adj: meta_adjunction D C F G φ ψ
using induces_meta_adjunction by simp
interpret Adj: adjunction D C replete_setcat.comp
Adj.φC Adj.φD F G φ ψ Adj.η Adj.ε Adj.Φ Adj.Ψ
using induces_adjunction by simp
interpret equivalence_of_categories D C F G Adj.η Adj.ε
proof
show 1: "⋀a. D.ide a ⟹ D.iso (Adj.ε a)"
proof -
fix a
assume a: "D.ide a"
interpret εa: terminal_arrow_from_functor C D F ‹G a› a ‹Adj.ε a›
using a Adj.has_terminal_arrows_from_functor [of a] by blast
have "D.retraction (Adj.ε a)"
proof -
obtain b φ where φ: "C.ide b ∧ D.iso φ ∧ «φ: F b →⇩D a»"
using a essentially_surjective by blast
interpret φ: arrow_from_functor C D F b a φ
using φ by (unfold_locales, simp)
let ?g = "εa.the_coext b φ"
have 1: "«?g : b →⇩C G a» ∧ Adj.ε a ⋅⇩D F ?g = φ"
using φ.arrow_from_functor_axioms εa.the_coext_prop [of b φ] by simp
have "a = (Adj.ε a ⋅⇩D F ?g) ⋅⇩D D.inv φ"
using a 1 φ D.comp_cod_arr Adj.ε.preserves_hom D.invert_side_of_triangle(2)
by auto
also have "... = Adj.ε a ⋅⇩D F ?g ⋅⇩D D.inv φ"
using a 1 φ D.inv_in_hom Adj.ε.preserves_hom [of a a a] D.comp_assoc
by blast
finally have "∃f. D.ide (Adj.ε a ⋅⇩D f)"
using a by metis
thus ?thesis
unfolding D.retraction_def by blast
qed
moreover have "D.mono (Adj.ε a)"
proof
show "D.arr (Adj.ε a)"
using a by simp
show "⋀f f'. D.seq (Adj.ε a) f ∧ D.seq (Adj.ε a) f' ∧ Adj.ε a ⋅⇩D f = Adj.ε a ⋅⇩D f'
⟹ f = f'"
proof -
fix f f'
assume ff': "D.seq (Adj.ε a) f ∧ D.seq (Adj.ε a) f' ∧ Adj.ε a ⋅⇩D f = Adj.ε a ⋅⇩D f'"
have f: "«f : D.dom f →⇩D F (G a)»"
using a ff' Adj.ε.preserves_hom [of a a a] by fastforce
have f': "«f' : D.dom f' →⇩D F (G a)»"
using a ff' Adj.ε.preserves_hom [of a a a] by fastforce
have par: "D.par f f'"
using f f' ff' D.dom_comp [of "Adj.ε a" f] by force
obtain b' φ where φ: "C.ide b' ∧ D.iso φ ∧ «φ: F b' →⇩D D.dom f»"
using par essentially_surjective D.ide_dom [of f] by blast
have 1: "Adj.ε a ⋅⇩D f ⋅⇩D φ = Adj.ε a ⋅⇩D f' ⋅⇩D φ"
using ff' φ par D.comp_assoc by metis
obtain g where g: "«g : b' →⇩C G a» ∧ F g = f ⋅⇩D φ"
using a f φ is_full [of "G a" b' "f ⋅⇩D φ"] by auto
obtain g' where g': "«g' : b' →⇩C G a» ∧ F g' = f' ⋅⇩D φ"
using a f' par φ is_full [of "G a" b' "f' ⋅⇩D φ"] by auto
interpret fφ: arrow_from_functor C D F b' a ‹Adj.ε a ⋅⇩D f ⋅⇩D φ›
using a φ f Adj.ε.preserves_hom
by (unfold_locales, fastforce)
interpret f'φ: arrow_from_functor C D F b' a ‹Adj.ε a ⋅⇩D f' ⋅⇩D φ›
using a φ f' par Adj.ε.preserves_hom
by (unfold_locales, fastforce)
have "εa.is_coext b' (Adj.ε a ⋅⇩D f ⋅⇩D φ) g"
unfolding εa.is_coext_def using g 1 by auto
moreover have "εa.is_coext b' (Adj.ε a ⋅⇩D f' ⋅⇩D φ) g'"
unfolding εa.is_coext_def using g' 1 by auto
ultimately have "g = g'"
using 1 fφ.arrow_from_functor_axioms f'φ.arrow_from_functor_axioms
εa.the_coext_unique εa.the_coext_unique [of b' "Adj.ε a ⋅⇩D f' ⋅⇩D φ" g']
by auto
hence "f ⋅⇩D φ = f' ⋅⇩D φ"
using g g' is_faithful by argo
thus "f = f'"
using φ f f' par D.iso_is_retraction D.retraction_is_epi D.epiE [of φ f f']
by auto
qed
qed
ultimately show "D.iso (Adj.ε a)"
using D.iso_iff_mono_and_retraction by simp
qed
interpret ε: natural_isomorphism D D ‹F o G› D.map Adj.ε
using 1 by (unfold_locales, auto)
interpret εF: natural_isomorphism C D ‹F o G o F› F ‹Adj.ε o F›
using ε.components_are_iso by (unfold_locales, simp)
show "⋀a. C.ide a ⟹ C.iso (Adj.η a)"
proof -
fix a
assume a: "C.ide a"
have "D.inverse_arrows ((Adj.ε o F) a) ((F o Adj.η) a)"
using a ε.components_are_iso Adj.ηε.triangle_F Adj.εFoFη.map_simp_ide
D.section_retraction_of_iso
by simp
hence "D.iso ((F o Adj.η) a)"
by blast
thus "C.iso (Adj.η a)"
using a reflects_iso [of "Adj.η a"] by fastforce
qed
qed
interpret adjoint_equivalence D C F G Adj.η Adj.ε ..
interpret ε': inverse_transformation D D ‹F o G› D.map Adj.ε ..
interpret η': inverse_transformation C C C.map ‹G o F› Adj.η ..
interpret E: adjoint_equivalence C D G F ε'.map η'.map
using adjoint_equivalence_axioms dual_equivalence by blast
show ?thesis
using E.adjoint_equivalence_axioms by auto
qed
lemma is_right_adjoint_functor:
shows "right_adjoint_functor C D F"
proof -
obtain G η ε where E: "adjoint_equivalence C D G F η ε"
using extends_to_adjoint_equivalence by auto
interpret E: adjoint_equivalence C D G F η ε
using E by simp
interpret Adj: meta_adjunction C D G F E.φ E.ψ
using E.induces_meta_adjunction by simp
show ?thesis
using Adj.has_right_adjoint_functor by simp
qed
lemma is_equivalence_functor:
shows "equivalence_functor C D F"
proof
obtain G η ε where E: "adjoint_equivalence C D G F η ε"
using extends_to_adjoint_equivalence by auto
interpret E: adjoint_equivalence C D G F η ε
using E by simp
have "equivalence_of_categories C D G F η ε" ..
thus "∃G η ε. equivalence_of_categories C D G F η ε" by blast
qed
sublocale equivalence_functor C D F
using is_equivalence_functor by blast
end
context equivalence_of_categories
begin
text ‹
The following development shows that an equivalence of categories can
be refined to an adjoint equivalence by replacing just the counit.
›
abbreviation ε'
where "ε' a ≡ ε a ⋅⇩C F (D.inv (η (G a))) ⋅⇩C C.inv (ε (F (G a)))"
interpretation ε': transformation_by_components C C ‹F ∘ G› C.map ε'
proof
show "⋀a. C.ide a ⟹ «ε' a : (F ∘ G) a →⇩C C.map a»"
using η.components_are_iso ε.components_are_iso by simp
fix f
assume f: "C.arr f"
show "ε' (C.cod f) ⋅⇩C (F ∘ G) f = C.map f ⋅⇩C ε' (C.dom f)"
proof -
have "ε' (C.cod f) ⋅⇩C (F ∘ G) f =
ε (C.cod f) ⋅⇩C F (D.inv (η (G (C.cod f)))) ⋅⇩C C.inv (ε (F (G (C.cod f)))) ⋅⇩C F (G f)"
using f C.comp_assoc by simp
also have "... = ε (C.cod f) ⋅⇩C (F (D.inv (η (G (C.cod f)))) ⋅⇩C
F (G (F (G f)))) ⋅⇩C C.inv (ε (F (G (C.dom f))))"
using f ε.inv_naturality [of "F (G f)"] C.comp_assoc by simp
also have "... = (ε (C.cod f) ⋅⇩C F (G f)) ⋅⇩C F (D.inv (η (G (C.dom f)))) ⋅⇩C
C.inv (ε (F (G (C.dom f))))"
proof -
have "F (D.inv (η (G (C.cod f)))) ⋅⇩C F (G (F (G f))) =
F (G f) ⋅⇩C F (D.inv (η (G (C.dom f))))"
proof -
have "F (D.inv (η (G (C.cod f)))) ⋅⇩C F (G (F (G f))) =
F (D.inv (η (G (C.cod f))) ⋅⇩D G (F (G f)))"
using f by simp
also have "... = F (G f ⋅⇩D D.inv (η (G (C.dom f))))"
using f η.inv_naturality [of "G f"] by simp
also have "... = F (G f) ⋅⇩C F (D.inv (η (G (C.dom f))))"
using f by simp
finally show ?thesis by blast
qed
thus ?thesis
using C.comp_assoc by simp
qed
also have "... = C.map f ⋅⇩C ε (C.dom f) ⋅⇩C F (D.inv (η (G (C.dom f)))) ⋅⇩C
C.inv (ε (F (G (C.dom f))))"
using f ε.naturality C.comp_assoc by simp
finally show ?thesis by blast
qed
qed
interpretation ε': natural_isomorphism C C ‹F ∘ G› C.map ε'.map
proof
show "⋀a. C.ide a ⟹ C.iso (ε'.map a)"
unfolding ε'.map_def
using η.components_are_iso ε.components_are_iso
apply simp
by (intro C.isos_compose) auto
qed
lemma Fη_inverse:
assumes "D.ide b"
shows "F (η (G (F b))) = F (G (F (η b)))"
and "F (η b) ⋅⇩C ε (F b) = ε (F (G (F b))) ⋅⇩C F (η (G (F b)))"
and "C.inverse_arrows (F (η b)) (ε' (F b))"
and "F (η b) = C.inv (ε' (F b))"
and "C.inv (F (η b)) = ε' (F b)"
proof -
let ?ε' = "λa. ε a ⋅⇩C F (D.inv (η (G a))) ⋅⇩C C.inv (ε (F (G a)))"
show 1: "F (η (G (F b))) = F (G (F (η b)))"
proof -
have "F (η (G (F b))) ⋅⇩C F (η b) = F (G (F (η b))) ⋅⇩C F (η b)"
proof -
have "F (η (G (F b))) ⋅⇩C F (η b) = F (η (G (F b)) ⋅⇩D η b)"
using assms by simp
also have "... = F (G (F (η b)) ⋅⇩D η b)"
using assms η.naturality [of "η b"] by simp
also have "... = F (G (F (η b))) ⋅⇩C F (η b)"
using assms by simp
finally show ?thesis by blast
qed
thus ?thesis
using assms η.components_are_iso C.iso_cancel_right by simp
qed
show "F (η b) ⋅⇩C ε (F b) = ε (F (G (F b))) ⋅⇩C F (η (G (F b)))"
using assms 1 ε.naturality [of "F (η b)"] by simp
show 2: "C.inverse_arrows (F (η b)) (?ε' (F b))"
proof
show 3: "C.ide (?ε' (F b) ⋅⇩C F (η b))"
proof -
have "?ε' (F b) ⋅⇩C F (η b) =
ε (F b) ⋅⇩C (F (D.inv (η (G (F b)))) ⋅⇩C C.inv (ε (F (G (F b))))) ⋅⇩C F (η b)"
using C.comp_assoc by simp
also have "... = ε (F b) ⋅⇩C (F (D.inv (η (G (F b)))) ⋅⇩C F (G (F (η b)))) ⋅⇩C C.inv (ε (F b))"
using assms ε.naturality [of "F (η b)"] ε.components_are_iso C.comp_assoc
C.invert_opposite_sides_of_square
[of "ε (F (G (F b)))" "F (G (F (η b)))" "F (η b)" "ε (F b)"]
by simp
also have "... = ε (F b) ⋅⇩C C.inv (ε (F b))"
proof -
have "F (D.inv (η (G (F b)))) ⋅⇩C F (G (F (η b))) = F (G (F b))"
using assms 1 D.comp_inv_arr' η.components_are_iso
by (metis D.ideD(1) D.ideD(2) F.preserves_comp
F.preserves_ide G.preserves_ide η.preserves_dom D.map_simp)
moreover have "F (G (F b)) ⋅⇩C C.inv (ε (F b)) = C.inv (ε (F b))"
using assms D.comp_cod_arr ε.components_are_iso C.inv_in_hom [of "ε (F b)"]
by (metis C.comp_ide_arr C_arr_expansion(1) D.ide_char F.preserves_arr
F.preserves_dom F.preserves_ide G.preserves_ide C.seqE)
ultimately show ?thesis by simp
qed
also have "... = F b"
using assms ε.components_are_iso C.comp_arr_inv' by simp
finally have "(ε (F b) ⋅⇩C F (D.inv (η (G (F b)))) ⋅⇩C C.inv (ε (F (G (F b))))) ⋅⇩C F (η b) = F b"
by blast
thus ?thesis
using assms by simp
qed
show "C.ide (F (η b) ⋅⇩C ?ε' (F b))"
proof -
have "(F (η b) ⋅⇩C ?ε' (F b)) ⋅⇩C F (η b) = F (G (F b)) ⋅⇩C F (η b)"
proof -
have "(F (η b) ⋅⇩C ?ε' (F b)) ⋅⇩C F (η b) =
F (η b) ⋅⇩C (ε (F b) ⋅⇩C F (D.inv (η (G (F b)))) ⋅⇩C C.inv (ε (F (G (F b))))) ⋅⇩C F (η b)"
using C.comp_assoc by simp
also have "... = F (η b)"
using assms 3
C.comp_arr_dom
[of "F (η b)" "(ε (F b) ⋅⇩C F (D.inv (η (G (F b)))) ⋅⇩C
C.inv (ε (F (G (F b))))) ⋅⇩C F (η b)"]
by auto
also have "... = F (G (F b)) ⋅⇩C F (η b)"
using assms C.comp_cod_arr by simp
finally show ?thesis by blast
qed
hence "F (η b) ⋅⇩C ?ε' (F b) = F (G (F b))"
using assms C.iso_cancel_right by simp
thus ?thesis
using assms by simp
qed
qed
show "C.inv (F (η b)) = ?ε' (F b)"
using assms 2 C.inverse_unique by simp
show "F (η b) = C.inv (?ε' (F b))"
proof -
have "C.inverse_arrows (?ε' (F b)) (F (η b))"
using assms 2 by auto
thus ?thesis
using assms C.inverse_unique by simp
qed
qed
interpretation FoGoF: composite_functor D C C F ‹F o G› ..
interpretation GoFoG: composite_functor C D D G ‹G o F› ..
interpretation natural_transformation D C F FoGoF.map ‹F ∘ η›
proof -
have "F ∘ D.map = F"
using hcomp_ide_dom F.natural_transformation_axioms by blast
moreover have "F o (G o F) = FoGoF.map"
by auto
ultimately show "natural_transformation D C F FoGoF.map (F ∘ η)"
using η.natural_transformation_axioms F.natural_transformation_axioms
horizontal_composite [of D D D.map "G o F" η C F F F]
by simp
qed
interpretation natural_transformation C D G GoFoG.map ‹η ∘ G›
using η.natural_transformation_axioms G.natural_transformation_axioms
horizontal_composite [of C D G G G ]
by fastforce
interpretation natural_transformation D C FoGoF.map F ‹ε'.map ∘ F›
using ε'.natural_transformation_axioms F.natural_transformation_axioms
horizontal_composite [of D C F F F]
by fastforce
interpretation natural_transformation C D GoFoG.map G ‹G ∘ ε'.map›
proof -
have "G o C.map = G"
using hcomp_ide_dom G.natural_transformation_axioms by blast
moreover have "G o (F o G) = GoFoG.map"
by auto
ultimately show "natural_transformation C D GoFoG.map G (G ∘ ε'.map)"
using G.natural_transformation_axioms ε'.natural_transformation_axioms
horizontal_composite [of C C "F o G" C.map ε'.map D G G G]
by simp
qed
interpretation ε'F_Fη: vertical_composite D C F FoGoF.map F ‹F ∘ η› ‹ε'.map ∘ F› ..
interpretation Gε'_ηG: vertical_composite C D G GoFoG.map G ‹η o G› ‹G o ε'.map› ..
interpretation ηε': unit_counit_adjunction C D F G η ε'.map
proof
show 1: "ε'F_Fη.map = F"
proof
fix g
show "ε'F_Fη.map g = F g"
proof (cases "D.arr g")
show "¬ D.arr g ⟹ ε'F_Fη.map g = F g"
using ε'F_Fη.is_extensional F.is_extensional by simp
assume g: "D.arr g"
have "ε'F_Fη.map g = ε' (F (D.cod g)) ⋅⇩C F (η g)"
using g ε'F_Fη.map_def by simp
also have "... = ε' (F (D.cod g)) ⋅⇩C F (η (D.cod g) ⋅⇩D g)"
using g η.is_natural_2 by simp
also have "... = (ε' (F (D.cod g)) ⋅⇩C F (η (D.cod g))) ⋅⇩C F g"
using g C.comp_assoc by simp
also have "... = F (D.cod g) ⋅⇩C F g"
using g Fη_inverse(3) [of "D.cod g"] by fastforce
also have "... = F g"
using g C.comp_cod_arr by simp
finally show "ε'F_Fη.map g = F g" by blast
qed
qed
show "Gε'_ηG.map = G"
proof
fix f
show "Gε'_ηG.map f = G f"
proof (cases "C.arr f")
show "¬ C.arr f ⟹ Gε'_ηG.map f = G f"
using Gε'_ηG.is_extensional G.is_extensional by simp
assume f: "C.arr f"
have "F (Gε'_ηG.map f) = F (G (ε' (C.cod f)) ⋅⇩D η (G f))"
using f Gε'_ηG.map_def D.comp_assoc by simp
also have "... = F (G (ε' (C.cod f)) ⋅⇩D η (G (C.cod f)) ⋅⇩D G f)"
using f η.is_natural_2 [of "G f"] by simp
also have "... = F (G (ε' (C.cod f))) ⋅⇩C F (η (G (C.cod f))) ⋅⇩C F (G f)"
using f by simp
also have "... = (F (G (ε' (C.cod f))) ⋅⇩C C.inv (ε' (F (G (C.cod f))))) ⋅⇩C F (G f)"
using f Fη_inverse(4) C.comp_assoc by simp
also have "... = (C.inv (ε' (C.cod f)) ⋅⇩C ε' (C.cod f)) ⋅⇩C F (G f)"
using f ε'.inv_naturality [of "ε' (C.cod f)"] by simp
also have "... = F (G (C.cod f)) ⋅⇩C F (G f)"
using f C.comp_inv_arr' [of "ε' (C.cod f)"] ε'.components_are_iso by simp
also have "... = F (G f)"
using f C.comp_cod_arr by simp
finally have "F (Gε'_ηG.map f) = F (G f)" by blast
moreover have "D.par (Gε'_ηG.map f) (G f)"
using f by simp
ultimately show "Gε'_ηG.map f = G f"
using f F_is_faithful
by (simp add: faithful_functor_axioms_def faithful_functor_def)
qed
qed
qed
interpretation ηε': adjoint_equivalence C D F G η ε'.map ..
lemma refines_to_adjoint_equivalence:
shows "adjoint_equivalence C D F G η ε'.map"
..
end
end
Theory CartesianCategory
chapter "Cartesian Category"
text‹
In this chapter, we explore the notion of a ``cartesian category'', which we define
to be a category having binary products and a terminal object.
We show that every cartesian category extends to an ``elementary cartesian category'',
whose definition assumes that specific choices have been made for projections and
terminal object.
Conversely, the underlying category of an elementary cartesian category is a
cartesian category.
We also show that cartesian categories are the same thing as categories with
finite products.
›
theory CartesianCategory
imports Limit SetCat
begin
section "Category with Binary Products"
subsection "Binary Product Diagrams"
text ‹
The ``shape'' of a binary product diagram is a category having two distinct identity arrows
and no non-identity arrows.
›
locale binary_product_shape
begin
sublocale concrete_category ‹UNIV :: bool set› ‹λa b. if a = b then {()} else {}›
‹λ_. ()› ‹λ_ _ _ _ _. ()›
apply (unfold_locales, auto)
apply (meson empty_iff)
by (meson empty_iff)
abbreviation comp
where "comp ≡ COMP"
abbreviation FF
where "FF ≡ MkIde False"
abbreviation TT
where "TT ≡ MkIde True"
lemma arr_char:
shows "arr f ⟷ f = FF ∨ f = TT"
using arr_char by (cases f, simp_all)
lemma ide_char:
shows "ide f ⟷ f = FF ∨ f = TT"
using ide_char ide_MkIde by (cases f, auto)
lemma is_discrete:
shows "ide f ⟷ arr f"
using arr_char ide_char by simp
lemma dom_simp [simp]:
assumes "arr f"
shows "dom f = f"
using assms is_discrete by simp
lemma cod_simp [simp]:
assumes "arr f"
shows "cod f = f"
using assms is_discrete by simp
lemma seq_char:
shows "seq f g ⟷ arr f ∧ f = g"
by auto
lemma comp_simp [simp]:
assumes "seq f g"
shows "comp f g = f"
using assms seq_char by fastforce
end
locale binary_product_diagram =
J: binary_product_shape +
C: category C
for C :: "'c comp" (infixr "⋅" 55)
and a0 :: 'c
and a1 :: 'c +
assumes is_discrete: "C.ide a0 ∧ C.ide a1"
begin
notation J.comp (infixr "⋅⇩J" 55)
fun map
where "map J.FF = a0"
| "map J.TT = a1"
| "map _ = C.null"
sublocale diagram J.comp C map
proof
show "⋀f. ¬ J.arr f ⟹ map f = C.null"
using J.arr_char map.elims by auto
fix f
assume f: "J.arr f"
show "C.arr (map f)"
using f J.arr_char is_discrete C.ideD(1) map.simps(1-2) by metis
show "C.dom (map f) = map (J.dom f)"
using f J.arr_char J.dom_char is_discrete by force
show "C.cod (map f) = map (J.cod f)"
using f J.arr_char J.cod_char is_discrete by force
next
fix f g
assume fg: "J.seq g f"
show "map (g ⋅⇩J f) = map g ⋅ map f"
using fg J.arr_char J.seq_char J.null_char J.not_arr_null is_discrete
by (metis (no_types, lifting) C.comp_ide_self J.comp_simp map.simps(1-2))
qed
end
subsection "Category with Binary Products"
text ‹
A \emph{binary product} in a category @{term C} is a limit of a binary product diagram
in @{term C}.
›
context binary_product_diagram
begin
definition mkCone
where "mkCone p0 p1 ≡ λj. if j = J.FF then p0 else if j = J.TT then p1 else C.null"
abbreviation is_rendered_commutative_by
where "is_rendered_commutative_by p0 p1 ≡
C.seq a0 p0 ∧ C.seq a1 p1 ∧ C.dom p0 = C.dom p1"
abbreviation has_as_binary_product
where "has_as_binary_product p0 p1 ≡ limit_cone (C.dom p0) (mkCone p0 p1)"
lemma cone_mkCone:
assumes "is_rendered_commutative_by p0 p1"
shows "cone (C.dom p0) (mkCone p0 p1)"
proof -
interpret E: constant_functor J.comp C ‹C.dom p0›
using assms by unfold_locales auto
show "cone (C.dom p0) (mkCone p0 p1)"
using assms mkCone_def J.arr_char E.map_simp is_discrete C.comp_ide_arr C.comp_arr_dom
by unfold_locales auto
qed
lemma is_rendered_commutative_by_cone:
assumes "cone a χ"
shows "is_rendered_commutative_by (χ J.FF) (χ J.TT)"
proof -
interpret χ: cone J.comp C map a χ
using assms by auto
show ?thesis
using is_discrete by simp
qed
lemma mkCone_cone:
assumes "cone a χ"
shows "mkCone (χ J.FF) (χ J.TT) = χ"
proof -
interpret χ: cone J.comp C map a χ
using assms by auto
interpret mkCone_χ: cone J.comp C map ‹C.dom (χ J.FF)› ‹mkCone (χ J.FF) (χ J.TT)›
using assms is_rendered_commutative_by_cone cone_mkCone by blast
show ?thesis
using mkCone_def χ.is_extensional J.ide_char mkCone_def
NaturalTransformation.eqI [of J.comp C]
χ.natural_transformation_axioms mkCone_χ.natural_transformation_axioms
by fastforce
qed
end
locale binary_product_cone =
J: binary_product_shape +
C: category C +
D: binary_product_diagram C f0 f1 +
limit_cone J.comp C D.map ‹C.dom p0› ‹D.mkCone p0 p1›
for C :: "'c comp" (infixr "⋅" 55)
and f0 :: 'c
and f1 :: 'c
and p0 :: 'c
and p1 :: 'c
begin
lemma renders_commutative:
shows "D.is_rendered_commutative_by p0 p1"
using cone_axioms D.is_rendered_commutative_by_cone D.mkCone_def Φ.Ya.Cop_S.arr.simps(1)
by (metis (no_types, lifting))
lemma is_universal':
assumes "D.is_rendered_commutative_by p0' p1'"
shows "∃!h. «h : C.dom p0' → C.dom p0» ∧ p0 ⋅ h = p0' ∧ p1 ⋅ h = p1'"
proof -
have "D.cone (C.dom p0') (D.mkCone p0' p1')"
using assms D.cone_mkCone by blast
hence "∃!h. «h : C.dom p0' → C.dom p0» ∧
D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
using is_universal by simp
moreover have "⋀h. «h : C.dom p0' → C.dom p0» ⟹
D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1' ⟷
p0 ⋅ h = p0' ∧ p1 ⋅ h = p1'"
proof -
fix h
assume h: "«h : C.dom p0' → C.dom p0»"
show "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1' ⟷
p0 ⋅ h = p0' ∧ p1 ⋅ h = p1'"
proof
assume 1: "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
show "p0 ⋅ h = p0' ∧ p1 ⋅ h = p1'"
proof
show "p0 ⋅ h = p0'"
proof -
have "p0' = D.mkCone p0' p1' J.FF"
using D.mkCone_def J.arr_char by simp
also have "... = D.cones_map h (D.mkCone p0 p1) J.FF"
using 1 by simp
also have "... = p0 ⋅ h"
using h D.mkCone_def J.arr_char cone_χ by auto
finally show ?thesis by auto
qed
show "p1 ⋅ h = p1'"
proof -
have "p1' = D.mkCone p0' p1' J.TT"
using D.mkCone_def J.arr_char by simp
also have "... = D.cones_map h (D.mkCone p0 p1) J.TT"
using 1 by simp
also have "... = p1 ⋅ h"
using h D.mkCone_def J.arr_char cone_χ by auto
finally show ?thesis by auto
qed
qed
next
assume 1: "p0 ⋅ h = p0' ∧ p1 ⋅ h = p1'"
show "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
using h 1 cone_χ D.mkCone_def by auto
qed
qed
ultimately show ?thesis by blast
qed
lemma induced_arrowI':
assumes "D.is_rendered_commutative_by p0' p1'"
shows "«induced_arrow (C.dom p0') (D.mkCone p0' p1') : C.dom p0' → C.dom p0»"
and "p0 ⋅ induced_arrow (C.dom p0') (D.mkCone p0' p1') = p0'"
and "p1 ⋅ induced_arrow (C.dom p1') (D.mkCone p0' p1') = p1'"
proof -
interpret A': constant_functor J.comp C ‹C.dom p0'›
using assms by (unfold_locales, auto)
have cone: "D.cone (C.dom p0') (D.mkCone p0' p1')"
using assms D.cone_mkCone [of p0' p1'] by blast
show 0: "p0 ⋅ induced_arrow (C.dom p0') (D.mkCone p0' p1') = p0'"
proof -
have "p0 ⋅ induced_arrow (C.dom p0') (D.mkCone p0' p1') =
D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
(D.mkCone p0 p1) J.FF"
using cone induced_arrowI(1) D.mkCone_def J.arr_char cone_χ by force
also have "... = p0'"
proof -
have "D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
(D.mkCone p0 p1) =
D.mkCone p0' p1'"
using cone induced_arrowI by blast
thus ?thesis
using J.arr_char D.mkCone_def by simp
qed
finally show ?thesis by auto
qed
show "p1 ⋅ induced_arrow (C.dom p1') (D.mkCone p0' p1') = p1'"
proof -
have "p1 ⋅ induced_arrow (C.dom p1') (D.mkCone p0' p1') =
D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
(D.mkCone p0 p1) J.TT"
using assms cone induced_arrowI(1) D.mkCone_def J.arr_char cone_χ by fastforce
also have "... = p1'"
proof -
have "D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
(D.mkCone p0 p1) =
D.mkCone p0' p1'"
using cone induced_arrowI by blast
thus ?thesis
using J.arr_char D.mkCone_def by simp
qed
finally show ?thesis by auto
qed
show "«induced_arrow (C.dom p0') (D.mkCone p0' p1') : C.dom p0' → C.dom p0»"
using 0 cone induced_arrowI by simp
qed
end
context category
begin
definition has_as_binary_product
where "has_as_binary_product a0 a1 p0 p1 ≡
ide a0 ∧ ide a1 ∧ binary_product_diagram.has_as_binary_product C a0 a1 p0 p1"
definition has_binary_products
where "has_binary_products =
(∀a0 a1. ide a0 ∧ ide a1 ⟶ (∃p0 p1. has_as_binary_product a0 a1 p0 p1))"
end
locale category_with_binary_products =
category +
assumes has_binary_products: has_binary_products
subsection "Elementary Category with Binary Products"
text ‹
An \emph{elementary category with binary products} is a category equipped with a specific
way of mapping each pair of objects ‹a› and ‹b› to a pair of arrows ‹𝔭⇩1[a, b]› and ‹𝔭⇩0[a, b]›
that comprise a universal span. It is useful to assume that the mappings that produce
‹𝔭⇩1[a, b]› and ‹𝔭⇩0[a, b]› from ‹a› and ‹b› are extensional; that is, if either ‹a› or ‹b›
is not an identity, then ‹𝔭⇩1[a, b]› and ‹𝔭⇩0[a, b]› are ‹null›.
›
locale elementary_category_with_binary_products =
category C
for C :: "'a comp" (infixr "⋅" 55)
and pr0 :: "'a ⇒ 'a ⇒ 'a" ("𝔭⇩0[_, _]")
and pr1 :: "'a ⇒ 'a ⇒ 'a" ("𝔭⇩1[_, _]") +
assumes pr0_ext: "¬ (ide a ∧ ide b) ⟹ 𝔭⇩0[a, b] = null"
and pr1_ext: "¬ (ide a ∧ ide b) ⟹ 𝔭⇩1[a, b] = null"
and span_pr: "⟦ ide a; ide b ⟧ ⟹ span 𝔭⇩1[a, b] 𝔭⇩0[a, b]"
and cod_pr0: "⟦ ide a; ide b ⟧ ⟹ cod 𝔭⇩0[a, b] = b"
and cod_pr1: "⟦ ide a; ide b ⟧ ⟹ cod 𝔭⇩1[a, b] = a"
and universal: "span f g ⟹ ∃!l. 𝔭⇩1[cod f, cod g] ⋅ l = f ∧ 𝔭⇩0[cod f, cod g] ⋅ l = g"
begin
lemma pr0_in_hom':
assumes "ide a" and "ide b"
shows "«𝔭⇩0[a, b] : dom 𝔭⇩0[a, b] → b»"
using assms span_pr cod_pr0 by auto
lemma pr1_in_hom':
assumes "ide a" and "ide b"
shows "«𝔭⇩1[a, b] : dom 𝔭⇩0[a, b] → a»"
using assms span_pr cod_pr1 by auto
text ‹
We introduce a notation for tupling, which denotes the arrow into a product that
is induced by a span.
›
definition tuple ("⟨_, _⟩")
where "⟨f, g⟩ ≡ if span f g then
THE l. 𝔭⇩1[cod f, cod g] ⋅ l = f ∧ 𝔭⇩0[cod f, cod g] ⋅ l = g
else null"
text ‹
The following defines product of arrows (not just of objects). It will take a little
while before we can prove that it is functorial, but for right now it is nice to have
it as a notation for the apex of a product cone. We have to go through some slightly
unnatural contortions in the development here, though, to avoid having to introduce a
separate preliminary notation just for the product of objects.
›
definition prod (infixr "⊗" 51)
where "f ⊗ g ≡ ⟨f ⋅ 𝔭⇩1[dom f, dom g], g ⋅ 𝔭⇩0[dom f, dom g]⟩"
lemma seq_pr_tuple:
assumes "span f g"
shows "seq 𝔭⇩0[cod f, cod g] ⟨f, g⟩"
proof -
have "𝔭⇩0[cod f, cod g] ⋅ ⟨f, g⟩ = g"
unfolding tuple_def
using assms universal theI [of "λl. 𝔭⇩1[cod f, cod g] ⋅ l = f ∧ 𝔭⇩0[cod f, cod g] ⋅ l = g"]
by simp meson
thus ?thesis
using assms by simp
qed
lemma tuple_pr_arr:
assumes "ide a" and "ide b" and "seq 𝔭⇩0[a, b] h"
shows "⟨𝔭⇩1[a, b] ⋅ h, 𝔭⇩0[a, b] ⋅ h⟩ = h"
unfolding tuple_def
using assms span_pr cod_pr0 cod_pr1 universal [of "𝔭⇩1[a, b] ⋅ h" "𝔭⇩0[a, b] ⋅ h"]
theI_unique [of "λl. 𝔭⇩1[a, b] ⋅ l = 𝔭⇩1[a, b] ⋅ h ∧ 𝔭⇩0[a, b] ⋅ l = 𝔭⇩0[a, b] ⋅ h" h]
by auto
lemma pr_tuple [simp]:
assumes "span f g" and "cod f = a" and "cod g = b"
shows "𝔭⇩1[a, b] ⋅ ⟨f, g⟩ = f" and "𝔭⇩0[a, b] ⋅ ⟨f, g⟩ = g"
proof -
have 1: "𝔭⇩1[a, b] ⋅ ⟨f, g⟩ = f ∧ 𝔭⇩0[a, b] ⋅ ⟨f, g⟩ = g"
unfolding tuple_def
using assms universal theI [of "λl. 𝔭⇩1[a, b] ⋅ l = f ∧ 𝔭⇩0[a, b] ⋅ l = g"]
by simp meson
show "𝔭⇩1[a, b] ⋅ ⟨f, g⟩ = f" using 1 by simp
show "𝔭⇩0[a, b] ⋅ ⟨f, g⟩ = g" using 1 by simp
qed
lemma cod_tuple:
assumes "span f g"
shows "cod ⟨f, g⟩ = cod f ⊗ cod g"
proof -
have "cod f ⊗ cod g = ⟨𝔭⇩1[cod f, cod g], 𝔭⇩0[cod f, cod g]⟩"
unfolding prod_def
using assms comp_cod_arr span_pr cod_pr0 cod_pr1 by simp
also have "... = ⟨𝔭⇩1[cod f, cod g] ⋅ dom 𝔭⇩0[cod f, cod g],
𝔭⇩0[cod f, cod g] ⋅ dom 𝔭⇩0[cod f, cod g]⟩"
using assms span_pr comp_arr_dom by simp
also have "... = dom 𝔭⇩0[cod f, cod g]"
using assms tuple_pr_arr span_pr by simp
also have "... = cod ⟨f, g⟩"
using assms seq_pr_tuple by blast
finally show ?thesis by simp
qed
lemma tuple_in_hom [intro]:
assumes "«f : a → b»" and "«g : a → c»"
shows "«⟨f, g⟩ : a → b ⊗ c»"
using assms pr_tuple dom_comp cod_tuple
apply (elim in_homE, intro in_homI)
apply (metis seqE)
by metis+
lemma tuple_in_hom' [simp]:
assumes "arr f" and "dom f = a" and "cod f = b"
and "arr g" and "dom g = a" and "cod g = c"
shows "«⟨f, g⟩ : a → b ⊗ c»"
using assms by auto
lemma tuple_ext:
assumes "¬ span f g"
shows "⟨f, g⟩ = null"
unfolding tuple_def
by (simp add: assms)
lemma tuple_simps [simp]:
assumes "span f g"
shows "arr ⟨f, g⟩" and "dom ⟨f, g⟩ = dom f" and "cod ⟨f, g⟩ = cod f ⊗ cod g"
proof -
show "arr ⟨f, g⟩"
using assms tuple_in_hom by blast
show "dom ⟨f, g⟩ = dom f"
using assms tuple_in_hom
by (metis dom_comp pr_tuple(1))
show "cod ⟨f, g⟩ = cod f ⊗ cod g"
using assms cod_tuple by auto
qed
lemma tuple_pr [simp]:
assumes "ide a" and "ide b"
shows "⟨𝔭⇩1[a, b], 𝔭⇩0[a, b]⟩ = a ⊗ b"
proof -
have 1: "dom 𝔭⇩0[a, b] = a ⊗ b"
using assms seq_pr_tuple cod_tuple [of "𝔭⇩1[a, b]" "𝔭⇩0[a, b]"] span_pr
pr0_in_hom' pr1_in_hom'
by (metis cod_pr0 cod_pr1 seqE)
hence "⟨𝔭⇩1[a, b], 𝔭⇩0[a, b]⟩ = ⟨𝔭⇩1[a, b] ⋅ (a ⊗ b), 𝔭⇩0[a, b] ⋅ (a ⊗ b)⟩"
using assms pr0_in_hom' pr1_in_hom' comp_arr_dom span_pr by simp
thus ?thesis
using assms 1 tuple_pr_arr span_pr
by (metis comp_arr_dom)
qed
lemma pr_in_hom [intro, simp]:
assumes "ide a" and "ide b"
shows "«𝔭⇩0[a, b] : a ⊗ b → b»" and "«𝔭⇩1[a, b] : a ⊗ b → a»"
proof -
show 0: "«𝔭⇩0[a, b] : a ⊗ b → b»"
using assms pr0_in_hom' seq_pr_tuple [of "𝔭⇩1[a, b]" "𝔭⇩0[a, b]"]
cod_tuple [of "𝔭⇩1[a, b]" "𝔭⇩0[a, b]"] span_pr cod_pr0 cod_pr1
by (intro in_homI, auto)
show "«𝔭⇩1[a, b] : a ⊗ b → a»"
using assms 0 span_pr pr1_in_hom' by fastforce
qed
lemma pr_simps [simp]:
assumes "ide a" and "ide b"
shows "arr 𝔭⇩0[a, b]" and "dom 𝔭⇩0[a, b] = a ⊗ b" and "cod 𝔭⇩0[a, b] = b"
and "arr 𝔭⇩1[a, b]" and "dom 𝔭⇩1[a, b] = a ⊗ b" and "cod 𝔭⇩1[a, b] = a"
using assms pr_in_hom by blast+
lemma arr_pr0_iff [iff]:
shows "arr 𝔭⇩0[a, b] ⟷ ide a ∧ ide b"
proof
show "ide a ∧ ide b ⟹ arr 𝔭⇩0[a, b]"
using pr_in_hom by auto
show "arr 𝔭⇩0[a, b] ⟹ ide a ∧ ide b"
using pr0_ext not_arr_null by metis
qed
lemma arr_pr1_iff [iff]:
shows "arr 𝔭⇩1[a, b] ⟷ ide a ∧ ide b"
proof
show "ide a ∧ ide b ⟹ arr 𝔭⇩1[a, b]"
using pr_in_hom by auto
show "arr 𝔭⇩1[a, b] ⟹ ide a ∧ ide b"
using pr1_ext not_arr_null by metis
qed
lemma pr_joint_monic:
assumes "seq 𝔭⇩0[a, b] h"
and "𝔭⇩0[a, b] ⋅ h = 𝔭⇩0[a, b] ⋅ h'" and "𝔭⇩1[a, b] ⋅ h = 𝔭⇩1[a, b] ⋅ h'"
shows "h = h'"
using assms
by (metis arr_pr0_iff seqE tuple_pr_arr)
lemma comp_tuple_arr [simp]:
assumes "span f g" and "arr h" and "dom f = cod h"
shows "⟨f, g⟩ ⋅ h = ⟨f ⋅ h, g ⋅ h⟩"
proof (intro pr_joint_monic [where h = "⟨f, g⟩ ⋅ h"])
show "seq 𝔭⇩0[cod f, cod g] (⟨f, g⟩ ⋅ h)"
using assms by fastforce
show "𝔭⇩0[cod f, cod g] ⋅ ⟨f, g⟩ ⋅ h = 𝔭⇩0[cod f, cod g] ⋅ ⟨f ⋅ h, g ⋅ h⟩"
proof -
have "𝔭⇩0[cod f, cod g] ⋅ ⟨f, g⟩ ⋅ h = (𝔭⇩0[cod f, cod g] ⋅ ⟨f, g⟩) ⋅ h"
using comp_assoc by simp
thus ?thesis
using assms by simp
qed
show "𝔭⇩1[cod f, cod g] ⋅ ⟨f, g⟩ ⋅ h = 𝔭⇩1[cod f, cod g] ⋅ ⟨f ⋅ h, g ⋅ h⟩"
proof -
have "𝔭⇩1[cod f, cod g] ⋅ ⟨f, g⟩ ⋅ h = (𝔭⇩1[cod f, cod g] ⋅ ⟨f, g⟩) ⋅ h"
using comp_assoc by simp
thus ?thesis
using assms by simp
qed
qed
lemma ide_prod [intro, simp]:
assumes "ide a" and "ide b"
shows "ide (a ⊗ b)"
using assms pr_simps ide_dom [of "𝔭⇩0[a, b]"] by simp
lemma prod_in_hom [intro]:
assumes "«f : a → c»" and "«g : b → d»"
shows "«f ⊗ g : a ⊗ b → c ⊗ d»"
using assms prod_def by fastforce
lemma prod_in_hom' [simp]:
assumes "arr f" and "dom f = a" and "cod f = c"
and "arr g" and "dom g = b" and "cod g = d"
shows "«f ⊗ g : a ⊗ b → c ⊗ d»"
using assms by blast
lemma prod_simps [simp]:
assumes "arr f0" and "arr f1"
shows "arr (f0 ⊗ f1)"
and "dom (f0 ⊗ f1) = dom f0 ⊗ dom f1"
and "cod (f0 ⊗ f1) = cod f0 ⊗ cod f1"
using assms prod_in_hom by blast+
end
subsection "Agreement between the Definitions"
text ‹
We now show that a category with binary products extends (by making a choice)
to an elementary category with binary products, and that the underlying category
of an elementary category with binary products is a category with binary products.
›
context category_with_binary_products
begin
definition pr1
where "pr1 a b ≡ if ide a ∧ ide b then
fst (SOME x. has_as_binary_product a b (fst x) (snd x))
else null"
definition pr0
where "pr0 a b ≡ if ide a ∧ ide b then
snd (SOME x. has_as_binary_product a b (fst x) (snd x))
else null"
lemma pr_yields_binary_product:
assumes "ide a" and "ide b"
shows "has_as_binary_product a b (pr1 a b) (pr0 a b)"
proof -
have "∃x. has_as_binary_product a b (fst x) (snd x)"
using assms has_binary_products has_binary_products_def has_as_binary_product_def
by simp
thus ?thesis
using assms has_binary_products has_binary_products_def pr0_def pr1_def
someI_ex [of "λx. has_as_binary_product a b (fst x) (snd x)"]
by simp
qed
interpretation elementary_category_with_binary_products C pr0 pr1
proof
show "⋀a b. ¬ (ide a ∧ ide b) ⟹ pr0 a b = null"
using pr0_def by auto
show "⋀a b. ¬ (ide a ∧ ide b) ⟹ pr1 a b = null"
using pr1_def by auto
fix a b
assume a: "ide a" and b: "ide b"
interpret J: binary_product_shape .
interpret D: binary_product_diagram C a b
using a b by unfold_locales auto
let ?χ = "D.mkCone (pr1 a b) (pr0 a b)"
interpret χ: limit_cone J.comp C D.map ‹dom (pr1 a b)› ?χ
using a b pr_yields_binary_product
by (simp add: has_as_binary_product_def)
have 1: "pr1 a b = ?χ J.FF ∧ pr0 a b = ?χ J.TT"
using D.mkCone_def by simp
show "span (pr1 a b) (pr0 a b)"
using 1 χ.preserves_reflects_arr J.seqE J.arr_char J.seq_char J.is_category
D.is_rendered_commutative_by_cone χ.cone_axioms
by metis
show "cod (pr1 a b) = a"
using 1 χ.preserves_cod [of J.FF] J.cod_char J.arr_char by auto
show "cod (pr0 a b) = b"
using 1 χ.preserves_cod [of J.TT] J.cod_char J.arr_char by auto
next
fix f g
assume fg: "span f g"
show "∃!l. pr1 (cod f) (cod g) ⋅ l = f ∧ pr0 (cod f) (cod g) ⋅ l = g"
proof -
interpret J: binary_product_shape .
interpret D: binary_product_diagram C ‹cod f› ‹cod g›
using fg by unfold_locales auto
let ?χ = "D.mkCone (pr1 (cod f) (cod g)) (pr0 (cod f) (cod g))"
interpret χ: limit_cone J.comp C D.map ‹dom (pr1 (cod f) (cod g))› ?χ
using fg pr_yields_binary_product [of "cod f" "cod g"] has_as_binary_product_def
by simp
interpret χ: binary_product_cone C ‹cod f› ‹cod g›
‹pr1 (cod f) (cod g)› ‹pr0 (cod f) (cod g)› ..
have 1: "pr1 (cod f) (cod g) = ?χ J.FF ∧ pr0 (cod f) (cod g) = ?χ J.TT"
using D.mkCone_def by simp
show "∃!l. pr1 (cod f) (cod g) ⋅ l = f ∧ pr0 (cod f) (cod g) ⋅ l = g"
proof -
have "∃!l. «l : dom f → dom (pr1 (cod f) (cod g))» ∧
pr1 (cod f) (cod g) ⋅ l = f ∧ pr0 (cod f) (cod g) ⋅ l = g"
using fg χ.is_universal' by simp
moreover have "⋀l. pr1 (cod f) (cod g) ⋅ l = f
⟹ «l : dom f → dom (pr1 (cod f) (cod g))»"
using fg dom_comp in_homI seqE seqI by metis
ultimately show ?thesis by auto
qed
qed
qed
proposition extends_to_elementary_category_with_binary_products:
shows "elementary_category_with_binary_products C pr0 pr1"
..
end
context elementary_category_with_binary_products
begin
interpretation category_with_binary_products C
proof
show "has_binary_products"
proof (unfold has_binary_products_def)
have "⋀a b. ide a ∧ ide b ⟹ ∃p0 p1. has_as_binary_product a b p0 p1"
proof -
fix a b
assume ab: "ide a ∧ ide b"
interpret J: binary_product_shape .
interpret D: binary_product_diagram C a b
using ab by unfold_locales auto
have 2: "D.is_rendered_commutative_by 𝔭⇩1[a, b] 𝔭⇩0[a, b]"
using ab by simp
let ?χ = "D.mkCone 𝔭⇩1[a, b] 𝔭⇩0[a, b]"
interpret χ: cone J.comp C D.map ‹dom 𝔭⇩1[a, b]› ?χ
using D.cone_mkCone 2 by auto
interpret χ: limit_cone J.comp C D.map ‹dom 𝔭⇩1[a, b]› ?χ
proof
fix a' χ'
assume χ': "D.cone a' χ'"
interpret χ': cone J.comp C D.map a' χ'
using χ' by simp
show "∃!h. «h : a' → dom 𝔭⇩1[a, b]» ∧
D.cones_map h (D.mkCone 𝔭⇩1[a, b] 𝔭⇩0[a, b]) = χ'"
proof
let ?h = "⟨χ' J.FF, χ' J.TT⟩"
show h': "«?h : a' → dom 𝔭⇩1[a, b]» ∧
D.cones_map ?h (D.mkCone 𝔭⇩1[a, b] 𝔭⇩0[a, b]) = χ'"
proof
show h: "«?h : a' → dom 𝔭⇩1[a, b]»"
using ab tuple_in_hom J.ide_char by fastforce
show "D.cones_map ?h (D.mkCone 𝔭⇩1[a, b] 𝔭⇩0[a, b]) = χ'"
proof -
interpret χ'h: cone J.comp C D.map a'
‹D.cones_map ?h (D.mkCone 𝔭⇩1[a, b] 𝔭⇩0[a, b])›
proof -
have "D.mkCone 𝔭⇩1[a, b] 𝔭⇩0[a, b] ∈ D.cones (cod ⟨χ' J.FF, χ' J.TT⟩)"
using ab h D.cone_mkCone D.is_rendered_commutative_by_cone
χ.cone_axioms
by auto
hence "D.cones_map ?h (D.mkCone 𝔭⇩1[a, b] 𝔭⇩0[a, b]) ∈ D.cones a'"
using ab h D.cones_map_mapsto by blast
thus "D.cone a' (D.cones_map ?h (D.mkCone 𝔭⇩1[a, b] 𝔭⇩0[a, b]))"
by simp
qed
show ?thesis
proof -
have "⋀j. J.ide j ⟹ D.cones_map ?h (D.mkCone 𝔭⇩1[a, b] 𝔭⇩0[a, b]) j = χ' j"
using ab h J.ide_char D.mkCone_def χ.cone_axioms by auto
thus ?thesis
using NaturalTransformation.eqI
χ'.natural_transformation_axioms χ'h.natural_transformation_axioms
by blast
qed
qed
qed
show "⋀h. «h : a' → dom 𝔭⇩1[a, b]» ∧
D.cones_map h (D.mkCone 𝔭⇩1[a, b] 𝔭⇩0[a, b]) = χ' ⟹ h = ?h"
proof -
fix h
assume 1: "«h : a' → dom 𝔭⇩1[a, b]» ∧
D.cones_map h (D.mkCone 𝔭⇩1[a, b] 𝔭⇩0[a, b]) = χ'"
hence "cod h = dom 𝔭⇩1[a, b]" by auto
show "h = ?h"
using 1 ab χ.cone_axioms D.mkCone_def h' pr_joint_monic [of a b h ?h]
by auto
qed
qed
qed
have "has_as_binary_product a b 𝔭⇩1[a, b] 𝔭⇩0[a, b]"
using ab has_as_binary_product_def χ.limit_cone_axioms by blast
thus "∃p0 p1. has_as_binary_product a b p0 p1"
by blast
qed
thus "∀a b. ide a ∧ ide b ⟶ (∃p0 p1. has_as_binary_product a b p0 p1)"
by simp
qed
qed
proposition is_category_with_binary_products:
shows "category_with_binary_products C"
..
end
subsection "Further Properties"
context elementary_category_with_binary_products
begin
lemma interchange:
assumes "seq h f" and "seq k g"
shows "(h ⊗ k) ⋅ (f ⊗ g) = h ⋅ f ⊗ k ⋅ g"
using assms prod_def comp_tuple_arr comp_assoc by fastforce
lemma pr_naturality [simp]:
assumes "arr g" and "dom g = b" and "cod g = d"
and "arr f" and "dom f = a" and "cod f = c"
shows "𝔭⇩0[c, d] ⋅ (f ⊗ g) = g ⋅ 𝔭⇩0[a, b]"
and "𝔭⇩1[c, d] ⋅ (f ⊗ g) = f ⋅ 𝔭⇩1[a, b]"
using assms prod_def by fastforce+
abbreviation dup ("𝖽[_]")
where "𝖽[f] ≡ ⟨f, f⟩"
lemma dup_in_hom [intro, simp]:
assumes "«f : a → b»"
shows "«𝖽[f] : a → b ⊗ b»"
using assms by fastforce
lemma dup_simps [simp]:
assumes "arr f"
shows "arr 𝖽[f]" and "dom 𝖽[f] = dom f" and "cod 𝖽[f] = cod f ⊗ cod f"
using assms dup_in_hom by auto
lemma dup_naturality:
assumes "«f : a → b»"
shows "𝖽[b] ⋅ f = (f ⊗ f) ⋅ 𝖽[a]"
using assms prod_def comp_arr_dom comp_cod_arr comp_tuple_arr comp_assoc
by fastforce
lemma pr_dup [simp]:
assumes "ide a"
shows "𝔭⇩0[a, a] ⋅ 𝖽[a] = a" and "𝔭⇩1[a, a] ⋅ 𝖽[a] = a"
using assms by simp_all
lemma prod_tuple:
assumes "span f g" and "seq h f" and "seq k g"
shows "(h ⊗ k) ⋅ ⟨f, g⟩ = ⟨h ⋅ f, k ⋅ g⟩"
using assms prod_def comp_assoc comp_tuple_arr by fastforce
lemma tuple_eqI:
assumes "seq 𝔭⇩0[b, c] f" and "seq 𝔭⇩1[b, c] f"
and "𝔭⇩0[b, c] ⋅ f = f0" and "𝔭⇩1[b, c] ⋅ f = f1"
shows "f = ⟨f1, f0⟩"
using assms pr_joint_monic [of b c "⟨f1, f0⟩" f] pr_tuple by auto
definition assoc ("𝖺[_, _, _]")
where "𝖺[a, b, c] ≡ ⟨𝔭⇩1[a, b] ⋅ 𝔭⇩1[a ⊗ b, c], ⟨𝔭⇩0[a, b] ⋅ 𝔭⇩1[a ⊗ b, c], 𝔭⇩0[a ⊗ b, c]⟩⟩"
definition assoc' ("𝖺⇧-⇧1[_, _, _]")
where "𝖺⇧-⇧1[a, b, c] ≡ ⟨⟨𝔭⇩1[a, b ⊗ c], 𝔭⇩1[b, c] ⋅ 𝔭⇩0[a, b ⊗ c]⟩, 𝔭⇩0[b, c] ⋅ 𝔭⇩0[a, b ⊗ c]⟩"
lemma assoc_in_hom [intro]:
assumes "ide a" and "ide b" and "ide c"
shows "«𝖺[a, b, c] : (a ⊗ b) ⊗ c → a ⊗ (b ⊗ c)»"
using assms assoc_def by auto
lemma assoc_simps [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "arr 𝖺[a, b, c]"
and "dom 𝖺[a, b, c] = (a ⊗ b) ⊗ c"
and "cod 𝖺[a, b, c] = a ⊗ (b ⊗ c)"
using assms assoc_in_hom by auto
lemma assoc'_in_hom [intro]:
assumes "ide a" and "ide b" and "ide c"
shows "«𝖺⇧-⇧1[a, b, c] : a ⊗ (b ⊗ c) → (a ⊗ b) ⊗ c»"
using assms assoc'_def by auto
lemma assoc'_simps [simp]:
assumes "ide a" and "ide b" and "ide c"
shows "arr 𝖺⇧-⇧1[a, b, c]"
and "dom 𝖺⇧-⇧1[a, b, c] = a ⊗ (b ⊗ c)"
and "cod 𝖺⇧-⇧1[a, b, c] = (a ⊗ b) ⊗ c"
using assms assoc'_in_hom by auto
lemma assoc_naturality:
assumes "«f0 : a0 → b0»" and "«f1 : a1 → b1»" and "«f2 : a2 → b2»"
shows "𝖺[b0, b1, b2] ⋅ ((f0 ⊗ f1) ⊗ f2) = (f0 ⊗ (f1 ⊗ f2)) ⋅ 𝖺[a0, a1, a2]"
proof -
have "𝔭⇩0[b0, b1 ⊗ b2] ⋅ 𝖺[b0, b1, b2] ⋅ ((f0 ⊗ f1) ⊗ f2) =
𝔭⇩0[b0, b1 ⊗ b2] ⋅ (f0 ⊗ (f1 ⊗ f2)) ⋅ 𝖺[a0, a1, a2]"
proof -
have "𝔭⇩0[b0, b1 ⊗ b2] ⋅ 𝖺[b0, b1, b2] ⋅ ((f0 ⊗ f1) ⊗ f2) =
(𝔭⇩0[b0, b1 ⊗ b2] ⋅ 𝖺[b0, b1, b2]) ⋅ ((f0 ⊗ f1) ⊗ f2)"
using comp_assoc by simp
also have "... = ⟨𝔭⇩0[b0, b1] ⋅ 𝔭⇩1[b0 ⊗ b1, b2], 𝔭⇩0[b0 ⊗ b1, b2]⟩ ⋅ ((f0 ⊗ f1) ⊗ f2)"
using assms assoc_def by fastforce
also have "... = ⟨(𝔭⇩0[b0, b1] ⋅ 𝔭⇩1[b0 ⊗ b1, b2]) ⋅ ((f0 ⊗ f1) ⊗ f2),
𝔭⇩0[b0 ⊗ b1, b2] ⋅ ((f0 ⊗ f1) ⊗ f2)⟩"
using assms comp_tuple_arr by fastforce
also have "... = ⟨(𝔭⇩0[b0, b1] ⋅ (f0 ⊗ f1)) ⋅ 𝔭⇩1[a0 ⊗ a1, a2], f2 ⋅ 𝔭⇩0[a0 ⊗ a1, a2]⟩"
using assms comp_assoc by fastforce
also have "... = ⟨f1 ⋅ 𝔭⇩0[a0, a1] ⋅ 𝔭⇩1[a0 ⊗ a1, a2], f2 ⋅ 𝔭⇩0[a0 ⊗ a1, a2]⟩"
using assms comp_assoc
by (metis in_homE pr_naturality(1))
also have "... = 𝔭⇩0[b0, b1 ⊗ b2] ⋅ (f0 ⊗ (f1 ⊗ f2)) ⋅ 𝖺[a0, a1, a2]"
using assms comp_assoc assoc_def prod_tuple by fastforce
finally show ?thesis by blast
qed
moreover have "𝔭⇩1[b0, b1 ⊗ b2] ⋅ 𝖺[b0, b1, b2] ⋅ ((f0 ⊗ f1) ⊗ f2) =
𝔭⇩1[b0, b1 ⊗ b2] ⋅ (f0 ⊗ (f1 ⊗ f2)) ⋅ 𝖺[a0, a1, a2]"
proof -
have "𝔭⇩1[b0, b1 ⊗ b2] ⋅ 𝖺[b0, b1, b2] ⋅ ((f0 ⊗ f1) ⊗ f2) =
(𝔭⇩1[b0, b1 ⊗ b2] ⋅ 𝖺[b0, b1, b2]) ⋅ ((f0 ⊗ f1) ⊗ f2)"
using comp_assoc by simp
also have "... = (𝔭⇩1[b0, b1] ⋅ 𝔭⇩1[b0 ⊗ b1, b2]) ⋅ ((f0 ⊗ f1) ⊗ f2)"
using assms assoc_def by fastforce
also have "... = (𝔭⇩1[b0, b1] ⋅ (f0 ⊗ f1)) ⋅ 𝔭⇩1[a0 ⊗ a1, a2]"
using assms comp_assoc by fastforce
also have "... = f0 ⋅ 𝔭⇩1[a0, a1] ⋅ 𝔭⇩1[a0 ⊗ a1, a2]"
using assms comp_assoc
by (metis in_homE pr_naturality(2))
also have "... = 𝔭⇩1[b0, b1 ⊗ b2] ⋅ (f0 ⊗ (f1 ⊗ f2)) ⋅ 𝖺[a0, a1, a2]"
proof -
have "𝔭⇩1[b0, b1 ⊗ b2] ⋅ (f0 ⊗ (f1 ⊗ f2)) ⋅ 𝖺[a0, a1, a2] =
(𝔭⇩1[b0, b1 ⊗ b2] ⋅ (f0 ⊗ (f1 ⊗ f2))) ⋅ 𝖺[a0, a1, a2]"
using comp_assoc by simp
also have "... = f0 ⋅ 𝔭⇩1[a0, a1 ⊗ a2] ⋅ 𝖺[a0, a1, a2]"
using assms comp_assoc by fastforce
also have "... = f0 ⋅ 𝔭⇩1[a0, a1] ⋅ 𝔭⇩1[a0 ⊗ a1, a2]"
using assms assoc_def by fastforce
finally show ?thesis by simp
qed
finally show ?thesis by blast
qed
ultimately show ?thesis
using assms pr_joint_monic [of b0 "b1 ⊗ b2" "𝖺[b0, b1, b2] ⋅ ((f0 ⊗ f1) ⊗ f2)"
"(f0 ⊗ (f1 ⊗ f2)) ⋅ 𝖺[a0, a1, a2]"]
by fastforce
qed
lemma pentagon:
assumes "ide a" and "ide b" and "ide c" and "ide d"
shows "((a ⊗ 𝖺[b, c, d]) ⋅ 𝖺[a, b ⊗ c, d]) ⋅ (𝖺[a, b, c] ⊗ d) = 𝖺[a, b, c ⊗ d] ⋅ 𝖺[a ⊗ b, c, d]"
proof (intro pr_joint_monic
[where h = "((a ⊗ 𝖺[b, c, d]) ⋅ 𝖺[a, b ⊗ c, d]) ⋅ (𝖺[a, b, c] ⊗ d)"
and h' = "𝖺[a, b, c ⊗ d] ⋅ 𝖺[a ⊗ b, c, d]"])
show "seq 𝔭⇩0[a, b ⊗ (c ⊗ d)] (((a ⊗ 𝖺[b, c, d]) ⋅ 𝖺[a, b ⊗ c, d]) ⋅ (𝖺[a, b, c] ⊗ d))"
using assms by simp
show "𝔭⇩1[a, b ⊗ c ⊗ d] ⋅ ((a ⊗ 𝖺[b, c, d]) ⋅ 𝖺[a, b ⊗ c, d]) ⋅ (𝖺[a, b, c] ⊗ d) =
𝔭⇩1[a, b ⊗ c ⊗ d] ⋅ 𝖺[a, b, c ⊗ d] ⋅ 𝖺[a ⊗ b, c, d]"
proof -
have "𝔭⇩1[a, b ⊗ c ⊗ d] ⋅ ((a ⊗ 𝖺[b, c, d]) ⋅ 𝖺[a, b ⊗ c, d]) ⋅ (𝖺[a, b, c] ⊗ d) =
((𝔭⇩1[a, b ⊗ c ⊗ d] ⋅ (a ⊗ 𝖺[b, c, d])) ⋅ 𝖺[a, b ⊗ c, d]) ⋅ (𝖺[a, b, c] ⊗ d)"
using comp_assoc by simp
also have "... = (𝔭⇩1[a, (b ⊗ c) ⊗ d] ⋅ 𝖺[a, b ⊗ c, d]) ⋅ (𝖺[a, b, c] ⊗ d)"
using assms pr_naturality(2) comp_cod_arr by force
also have "... = 𝔭⇩1[a, b ⊗ c] ⋅ 𝔭⇩1[a ⊗ b ⊗ c, d] ⋅ (𝖺[a, b, c] ⊗ d)"
using assms assoc_def comp_assoc by simp
also have "... = (𝔭⇩1[a, b ⊗ c] ⋅ 𝖺[a, b, c]) ⋅ 𝔭⇩1[(a ⊗ b) ⊗ c, d]"
using assms pr_naturality(2) comp_assoc by fastforce
also have "... = 𝔭⇩1[a, b] ⋅ 𝔭⇩1[a ⊗ b, c] ⋅ 𝔭⇩1[(a ⊗ b) ⊗ c, d]"
using assms assoc_def comp_assoc by simp
finally have "𝔭⇩1[a, b ⊗ c ⊗ d] ⋅ ((a ⊗ 𝖺[b, c, d]) ⋅ 𝖺[a, b ⊗ c, d]) ⋅ (𝖺[a, b, c] ⊗ d) =
𝔭⇩1[a, b] ⋅ 𝔭⇩1[a ⊗ b, c] ⋅ 𝔭⇩1[(a ⊗ b) ⊗ c, d]"
by blast
also have "... = 𝔭⇩1[a, b ⊗ c ⊗ d] ⋅ 𝖺[a, b, c ⊗ d] ⋅ 𝖺[a ⊗ b, c, d]"
using assms assoc_def comp_assoc by auto
finally show ?thesis by blast
qed
show "𝔭⇩0[a, b ⊗ (c ⊗ d)] ⋅ ((a ⊗ 𝖺[b, c, d]) ⋅ 𝖺[a, b ⊗ c, d]) ⋅ (𝖺[a, b, c] ⊗ d) =
𝔭⇩0[a, b ⊗ (c ⊗ d)] ⋅ 𝖺[a, b, c ⊗ d] ⋅ 𝖺[a ⊗ b, c, d]"
proof -
have "𝔭⇩0[a, b ⊗ (c ⊗ d)] ⋅ ((a ⊗ 𝖺[b, c, d]) ⋅ 𝖺[a, b ⊗ c, d]) ⋅ (𝖺[a, b, c] ⊗ d) =
𝔭⇩0[a, b ⊗ c ⊗ d] ⋅
((a ⊗ ⟨𝔭⇩1[b, c] ⋅ 𝔭⇩1[b ⊗ c, d], ⟨𝔭⇩0[b, c] ⋅ 𝔭⇩1[b ⊗ c, d], 𝔭⇩0[b ⊗ c, d]⟩⟩) ⋅
⟨𝔭⇩1[a, b ⊗ c] ⋅ 𝔭⇩1[a ⊗ b ⊗ c, d],
⟨𝔭⇩0[a, b ⊗ c] ⋅ 𝔭⇩1[a ⊗ b ⊗ c, d], 𝔭⇩0[a ⊗ b ⊗ c, d]⟩⟩) ⋅
(⟨𝔭⇩1[a, b] ⋅ 𝔭⇩1[a ⊗ b, c], ⟨𝔭⇩0[a, b] ⋅ 𝔭⇩1[a ⊗ b, c], 𝔭⇩0[a ⊗ b, c]⟩⟩ ⊗ d)"
using assms assoc_def by simp
also have "... = ⟨𝔭⇩1[b, c] ⋅ 𝔭⇩1[b ⊗ c, d],
⟨𝔭⇩0[b, c] ⋅ 𝔭⇩1[b ⊗ c, d], 𝔭⇩0[b ⊗ c, d]⟩⟩ ⋅ (𝔭⇩0[a, (b ⊗ c) ⊗ d] ⋅
⟨𝔭⇩1[a, b ⊗ c] ⋅ 𝔭⇩1[a ⊗ b ⊗ c, d],
⟨𝔭⇩0[a, b ⊗ c] ⋅ 𝔭⇩1[a ⊗ b ⊗ c, d], 𝔭⇩0[a ⊗ b ⊗ c, d]⟩⟩) ⋅
(⟨𝔭⇩1[a, b] ⋅ 𝔭⇩1[a ⊗ b, c],
⟨𝔭⇩0[a, b] ⋅ 𝔭⇩1[a ⊗ b, c], 𝔭⇩0[a ⊗ b, c]⟩⟩ ⊗ d)"
proof -
have "𝔭⇩0[a, b ⊗ c ⊗ d] ⋅
(a ⊗ ⟨𝔭⇩1[b, c] ⋅ 𝔭⇩1[b ⊗ c, d], ⟨𝔭⇩0[b, c] ⋅ 𝔭⇩1[b ⊗ c, d], 𝔭⇩0[b ⊗ c, d]⟩⟩) =
⟨𝔭⇩1[b, c] ⋅ 𝔭⇩1[b ⊗ c, d], ⟨𝔭⇩0[b, c] ⋅ 𝔭⇩1[b ⊗ c, d], 𝔭⇩0[b ⊗ c, d]⟩⟩ ⋅
𝔭⇩0[a, (b ⊗ c) ⊗ d]"
using assms assoc_def ide_in_hom pr_naturality(1) by auto
thus ?thesis using comp_assoc by metis
qed
also have "... = ⟨𝔭⇩0[a, b] ⋅ 𝔭⇩1[a ⊗ b, c] ⋅ 𝔭⇩1[(a ⊗ b) ⊗ c, d],
⟨𝔭⇩0[a ⊗ b, c] ⋅ 𝔭⇩1[(a ⊗ b) ⊗ c, d], d ⋅ 𝔭⇩0[(a ⊗ b) ⊗ c, d]⟩⟩"
using assms comp_assoc by simp
also have "... = ⟨𝔭⇩0[a, b] ⋅ 𝔭⇩1[a ⊗ b, c] ⋅ 𝔭⇩1[(a ⊗ b) ⊗ c, d],
⟨𝔭⇩0[a ⊗ b, c] ⋅ 𝔭⇩1[(a ⊗ b) ⊗ c, d], 𝔭⇩0[(a ⊗ b) ⊗ c, d]⟩⟩"
using assms comp_cod_arr by simp
also have "... = 𝔭⇩0[a, b ⊗ (c ⊗ d)] ⋅ 𝖺[a, b, c ⊗ d] ⋅ 𝖺[a ⊗ b, c, d]"
using assms assoc_def comp_assoc by simp
finally show ?thesis by simp
qed
qed
lemma inverse_arrows_assoc:
assumes "ide a" and "ide b" and "ide c"
shows "inverse_arrows 𝖺[a, b, c] 𝖺⇧-⇧1[a, b, c]"
using assms assoc_def assoc'_def comp_assoc
by (auto simp add: tuple_pr_arr)
interpretation CC: product_category C C ..
abbreviation Prod
where "Prod fg ≡ fst fg ⊗ snd fg"
abbreviation Prod'
where "Prod' fg ≡ snd fg ⊗ fst fg"
interpretation Π: binary_functor C C C Prod
using tuple_ext CC.comp_char interchange
apply unfold_locales
apply auto
by (metis prod_def seqE)+
interpretation Prod': binary_functor C C C Prod'
using tuple_ext CC.comp_char interchange
apply unfold_locales
apply auto
by (metis prod_def seqE)+
lemma binary_functor_Prod:
shows "binary_functor C C C Prod" and "binary_functor C C C Prod'"
..
definition sym ("𝗌[_, _]")
where "𝗌[a1, a0] ≡ if ide a0 ∧ ide a1 then ⟨𝔭⇩0[a1, a0], 𝔭⇩1[a1, a0]⟩ else null"
lemma sym_in_hom [intro]:
assumes "ide a" and "ide b"
shows "«𝗌[a, b] : a ⊗ b → b ⊗ a»"
using assms sym_def by auto
lemma sym_simps [simp]:
assumes "ide a" and "ide b"
shows "arr 𝗌[a, b]" and "dom 𝗌[a, b] = a ⊗ b" and "cod 𝗌[a, b] = b ⊗ a"
using assms sym_in_hom by auto
lemma comp_sym_tuple [simp]:
assumes "«f0 : a → b0»" and "«f1 : a → b1»"
shows "𝗌[b0, b1] ⋅ ⟨f0, f1⟩ = ⟨f1, f0⟩"
using assms sym_def comp_tuple_arr by fastforce
lemma prj_sym [simp]:
assumes "ide a0" and "ide a1"
shows "𝔭⇩0[a1, a0] ⋅ 𝗌[a0, a1] = 𝔭⇩1[a0, a1]"
and "𝔭⇩1[a1, a0] ⋅ 𝗌[a0, a1] = 𝔭⇩0[a0, a1]"
using assms sym_def by auto
lemma comp_sym_sym [simp]:
assumes "ide a0" and "ide a1"
shows "𝗌[a1, a0] ⋅ 𝗌[a0, a1] = (a0 ⊗ a1)"
using assms sym_def comp_tuple_arr by auto
lemma sym_inverse_arrows:
assumes "ide a0" and "ide a1"
shows "inverse_arrows 𝗌[a0, a1] 𝗌[a1, a0]"
using assms sym_in_hom comp_sym_sym by auto
lemma sym_assoc_coherence:
assumes "ide a" and "ide b" and "ide c"
shows "𝖺[b, c, a] ⋅ 𝗌[a, b ⊗ c] ⋅ 𝖺[a, b, c] = (b ⊗ 𝗌[a, c]) ⋅ 𝖺[b, a, c] ⋅ (𝗌[a, b] ⊗ c)"
using assms sym_def assoc_def comp_assoc prod_tuple comp_cod_arr by simp
lemma sym_naturality:
assumes "«f0 : a0 → b0»" and "«f1 : a1 → b1»"
shows "𝗌[b0, b1] ⋅ (f0 ⊗ f1) = (f1 ⊗ f0) ⋅ 𝗌[a0, a1]"
using assms sym_def comp_assoc prod_tuple by fastforce
abbreviation σ
where "σ fg ≡ 𝗌[cod (fst fg), cod (snd fg)] ⋅ (fst fg ⊗ snd fg)"
interpretation σ: natural_transformation CC.comp C Prod Prod' σ
using sym_def CC.arr_char CC.null_char comp_arr_dom comp_cod_arr
apply unfold_locales
apply auto
using arr_cod_iff_arr ideD(1)
apply metis
using arr_cod_iff_arr ideD(1)
apply metis
using prod_tuple by simp
lemma σ_is_natural_transformation:
shows "natural_transformation CC.comp C Prod Prod' σ"
..
abbreviation Diag
where "Diag f ≡ if arr f then (f, f) else CC.null"
interpretation Δ: "functor" C CC.comp Diag
by (unfold_locales, auto)
lemma functor_Diag:
shows "functor C CC.comp Diag"
..
interpretation ΔoΠ: composite_functor CC.comp C CC.comp Prod Diag ..
interpretation ΠoΔ: composite_functor C CC.comp C Diag Prod ..
abbreviation π
where "π ≡ λ(f, g). (𝔭⇩1[cod f, cod g] ⋅ (f ⊗ g), 𝔭⇩0[cod f, cod g] ⋅ (f ⊗ g))"
interpretation π: transformation_by_components CC.comp CC.comp ΔoΠ.map CC.map π
using pr_naturality comp_arr_dom comp_cod_arr
by unfold_locales auto
lemma π_is_natural_transformation:
shows "natural_transformation CC.comp CC.comp ΔoΠ.map CC.map π"
proof -
have "π.map = π"
using π.map_def ext Π.is_extensional comp_arr_dom comp_cod_arr by auto
thus "natural_transformation CC.comp CC.comp ΔoΠ.map CC.map π"
using π.natural_transformation_axioms by simp
qed
interpretation δ: natural_transformation C C map ΠoΔ.map dup
using dup_naturality comp_arr_dom comp_cod_arr prod_tuple tuple_ext
by unfold_locales auto
lemma dup_is_natural_transformation:
shows "natural_transformation C C map ΠoΔ.map dup"
..
interpretation ΔoΠoΔ: composite_functor C CC.comp CC.comp Diag ΔoΠ.map ..
interpretation ΠoΔoΠ: composite_functor CC.comp C C Prod ΠoΔ.map ..
interpretation Δoδ: natural_transformation C CC.comp Diag ΔoΠoΔ.map ‹Diag ∘ dup›
proof -
have "Diag ∘ map = Diag"
by auto
thus "natural_transformation C CC.comp Diag ΔoΠoΔ.map (Diag ∘ dup)"
using Δ.natural_transformation_axioms δ.natural_transformation_axioms o_assoc
horizontal_composite [of C C map ΠoΔ.map dup CC.comp Diag Diag Diag]
by metis
qed
interpretation δoΠ: natural_transformation CC.comp C Prod ΠoΔoΠ.map ‹dup ∘ Prod›
using δ.natural_transformation_axioms Π.natural_transformation_axioms o_assoc
horizontal_composite [of CC.comp C Prod Prod Prod C map ΠoΔ.map dup]
by simp
interpretation πoΔ: natural_transformation C CC.comp ΔoΠoΔ.map Diag ‹π.map ∘ Diag›
using π.natural_transformation_axioms Δ.natural_transformation_axioms
horizontal_composite
[of C CC.comp Diag Diag Diag CC.comp ΔoΠ.map CC.map π.map]
by simp
interpretation Πoπ: natural_transformation CC.comp C ΠoΔoΠ.map Prod ‹Prod ∘ π.map›
proof -
have "Prod ∘ ΔoΠ.map = ΠoΔoΠ.map"
by auto
thus "natural_transformation CC.comp C ΠoΔoΠ.map Prod (Prod ∘ π.map)"
using π.natural_transformation_axioms Π.natural_transformation_axioms o_assoc
horizontal_composite
[of CC.comp CC.comp ΔoΠ.map CC.map π.map C Prod Prod Prod]
by simp
qed
interpretation Δoδ_πoΔ: vertical_composite C CC.comp Diag ΔoΠoΔ.map Diag
‹Diag ∘ dup› ‹π.map ∘ Diag›
..
interpretation Πoπ_δoΠ: vertical_composite CC.comp C Prod ΠoΔoΠ.map Prod
‹dup ∘ Prod› ‹Prod ∘ π.map›
..
interpretation ΔΠ: unit_counit_adjunction CC.comp C Diag Prod dup π.map
proof
show "Δoδ_πoΔ.map = Diag"
proof
fix f
have "¬ arr f ⟹ Δoδ_πoΔ.map f = Diag f"
by (simp add: Δoδ_πoΔ.is_extensional)
moreover have "arr f ⟹ Δoδ_πoΔ.map f = Diag f"
using comp_cod_arr comp_assoc Δoδ_πoΔ.map_def by auto
ultimately show "Δoδ_πoΔ.map f = Diag f" by blast
qed
show "Πoπ_δoΠ.map = Prod"
proof
fix fg
show "Πoπ_δoΠ.map fg = Prod fg"
proof -
have "¬ CC.arr fg ⟹ ?thesis"
by (simp add: Π.is_extensional Πoπ_δoΠ.is_extensional)
moreover have "CC.arr fg ⟹ ?thesis"
proof -
assume fg: "CC.arr fg"
have 1: "dup (Prod fg) = ⟨cod (fst fg) ⊗ cod (snd fg), cod (fst fg) ⊗ cod (snd fg)⟩ ⋅
(fst fg ⊗ snd fg)"
using fg δ.is_natural_2
apply simp
by (metis (no_types, lifting) prod_simps(1) prod_simps(3))
have "Πoπ_δoΠ.map fg =
(𝔭⇩1[cod (fst fg), cod (snd fg)] ⊗ 𝔭⇩0[cod (fst fg), cod (snd fg)]) ⋅
⟨cod (fst fg) ⊗ cod (snd fg), cod (fst fg) ⊗ cod (snd fg)⟩ ⋅
(fst fg ⊗ snd fg)"
using fg 1 Πoπ_δoΠ.map_def comp_cod_arr by simp
also have "... = ((𝔭⇩1[cod (fst fg), cod (snd fg)] ⊗ 𝔭⇩0[cod (fst fg), cod (snd fg)]) ⋅
⟨cod (fst fg) ⊗ cod (snd fg), cod (fst fg) ⊗ cod (snd fg)⟩) ⋅
(fst fg ⊗ snd fg)"
using comp_assoc by simp
also have "... = ⟨𝔭⇩1[cod (fst fg), cod (snd fg)] ⋅ (cod (fst fg) ⊗ cod (snd fg)),
𝔭⇩0[cod (fst fg), cod (snd fg)] ⋅ (cod (fst fg) ⊗ cod (snd fg))⟩ ⋅
(fst fg ⊗ snd fg)"
using fg prod_tuple by simp
also have "... = Prod fg"
using fg comp_arr_dom Π.is_natural_2 by auto
finally show ?thesis by simp
qed
ultimately show ?thesis by blast
qed
qed
qed
proposition induces_unit_counit_adjunction:
shows "unit_counit_adjunction CC.comp C Diag Prod dup π.map"
using ΔΠ.unit_counit_adjunction_axioms by simp
end
section "Category with Terminal Object"
locale category_with_terminal_object =
category +
assumes has_terminal: "∃t. terminal t"
locale elementary_category_with_terminal_object =
category C
for C :: "'a comp" (infixr "⋅" 55)
and one :: "'a" ("𝟭")
and trm :: "'a ⇒ 'a" ("𝗍[_]") +
assumes ide_one: "ide 𝟭"
and trm_in_hom: "ide a ⟹ «𝗍[a] : a → 𝟭»"
and trm_eqI: "⟦ ide a; «f : a → 𝟭» ⟧ ⟹ f = 𝗍[a]"
begin
lemma trm_simps:
assumes "ide a"
shows "arr 𝗍[a]" and "dom 𝗍[a] = a" and "cod 𝗍[a] = 𝟭"
using assms trm_in_hom by auto
lemma trm_one:
shows "𝗍[𝟭] = 𝟭"
using ide_one trm_in_hom trm_eqI ide_in_hom by auto
lemma terminal_one:
shows "terminal 𝟭"
using ide_one trm_in_hom trm_eqI terminal_def by metis
lemma trm_naturality:
assumes "arr f"
shows "𝗍[cod f] ⋅ f = 𝗍[dom f]"
using assms trm_eqI
by (metis comp_in_homI' ide_cod ide_dom in_homE trm_in_hom)
proposition is_category_with_terminal_object:
shows "category_with_terminal_object C"
apply unfold_locales
using terminal_one by auto
end
context category_with_terminal_object
begin
definition some_terminal ("𝟭")
where "some_terminal ≡ SOME t. terminal t"
definition "trm" ("𝗍[_]")
where "𝗍[f] ≡ if arr f then THE t. «t : dom f → 𝟭» else null"
lemma terminal_some_terminal [intro]:
shows "terminal 𝟭"
using some_terminal_def has_terminal someI_ex [of "λt. terminal t"] by presburger
lemma ide_some_terminal:
shows "ide 𝟭"
using terminal_def by blast
lemma trm_in_hom [intro]:
assumes "arr f"
shows "«𝗍[f] : dom f → 𝟭»"
proof -
have "ide (dom f)" using assms by fastforce
hence "∃!t. «t : dom f → 𝟭»"
using assms trm_def terminal_def terminal_some_terminal by simp
thus ?thesis
using assms trm_def [of f] theI' [of "λt. «t : dom f → 𝟭»"] by auto
qed
lemma trm_simps [simp]:
assumes "arr f"
shows "arr 𝗍[f]" and "dom 𝗍[f] = dom f" and "cod 𝗍[f] = 𝟭"
using assms trm_in_hom by auto
lemma trm_eqI:
assumes "«t : dom f → 𝟭»"
shows "t = 𝗍[f]"
proof -
have "ide (dom f)" using assms
by (metis ide_dom in_homE)
hence "∃!t. «t : dom f → 𝟭»"
using terminal_def [of 𝟭] terminal_some_terminal by auto
moreover have "«t : dom f → 𝟭»"
using assms by simp
ultimately show ?thesis
using assms trm_def the1_equality [of "λt. «t : dom f → 𝟭»" t]
‹ide (dom f)› arr_dom_iff_arr
by fastforce
qed
sublocale elementary_category_with_terminal_object C 𝟭 trm
using ide_some_terminal trm_eqI
by unfold_locales auto
proposition extends_to_elementary_category_with_terminal_object:
shows "elementary_category_with_terminal_object C 𝟭 trm"
..
end
section "Cartesian Category"
locale cartesian_category =
category_with_binary_products +
category_with_terminal_object
locale elementary_cartesian_category =
elementary_category_with_binary_products +
elementary_category_with_terminal_object
begin
proposition is_cartesian_category:
shows "cartesian_category C"
using cartesian_category.intro is_category_with_binary_products
is_category_with_terminal_object
by auto
end
context cartesian_category
begin
proposition extends_to_elementary_cartesian_category:
shows "elementary_cartesian_category C pr0 pr1 𝟭 trm"
by (simp add: elementary_cartesian_category_def
elementary_category_with_terminal_object_axioms
extends_to_elementary_category_with_binary_products)
sublocale elementary_cartesian_category C pr0 pr1 𝟭 trm
using extends_to_elementary_cartesian_category by simp
end
text ‹
Here we prove some facts that will later allow us to show that an elementary cartesian
category is a monoidal category.
›
context elementary_cartesian_category
begin
abbreviation ι
where "ι ≡ 𝔭⇩0[𝟭, 𝟭]"
lemma pr_coincidence:
shows "ι = 𝔭⇩1[𝟭, 𝟭]"
using ide_one
by (simp add: terminal_arr_unique terminal_one)
lemma ι_is_terminal_arr:
shows "terminal_arr ι"
using ide_one
by (simp add: terminal_one)
lemma inverse_arrows_ι:
shows "inverse_arrows ι ⟨𝟭, 𝟭⟩"
using ide_one
by (metis (no_types, lifting) dup_is_natural_transformation ι_is_terminal_arr cod_pr0
comp_cod_arr pr_dup(1) ide_dom inverse_arrows_def map_simp
natural_transformation.is_natural_2 pr_simps(2) pr1_in_hom' trm_eqI trm_naturality
trm_one tuple_pr)
lemma ι_is_iso:
shows "iso ι"
using inverse_arrows_ι by auto
lemma trm_tensor:
assumes "ide a" and "ide b"
shows "𝗍[a ⊗ b] = ι ⋅ (𝗍[a] ⊗ 𝗍[b])"
proof -
have "𝗍[a ⊗ b] = 𝗍[a] ⋅ 𝔭⇩1[a, b]"
by (metis assms(1-2) cod_pr1 pr_simps(4-6) trm_naturality)
moreover have "«𝗍[b] : b → 𝟭»"
using assms(2) trm_in_hom by blast
ultimately show ?thesis
using assms(1) pr_coincidence trm_in_hom by fastforce
qed
abbreviation runit ("𝗋[_]")
where "𝗋[a] ≡ 𝔭⇩1[a, 𝟭]"
abbreviation runit' ("𝗋⇧-⇧1[_]")
where "𝗋⇧-⇧1[a] ≡ ⟨a, 𝗍[a]⟩"
abbreviation lunit ("𝗅[_]")
where "𝗅[a] ≡ 𝔭⇩0[𝟭, a]"
abbreviation lunit' ("𝗅⇧-⇧1[_]")
where "𝗅⇧-⇧1[a] ≡ ⟨𝗍[a], a⟩"
lemma runit_in_hom:
assumes "ide a"
shows "«𝗋[a] : a ⊗ 𝟭 → a»"
using assms ide_one by simp
lemma runit'_in_hom:
assumes "ide a"
shows "«𝗋⇧-⇧1[a] : a → a ⊗ 𝟭»"
using assms ide_in_hom trm_in_hom by blast
lemma lunit_in_hom:
assumes "ide a"
shows "«𝗅[a] : 𝟭 ⊗ a → a»"
using assms ide_one by simp
lemma lunit'_in_hom:
assumes "ide a"
shows "«𝗅⇧-⇧1[a] : a → 𝟭 ⊗ a»"
using assms ide_in_hom trm_in_hom by blast
lemma runit_naturality:
assumes "ide a"
shows "𝗋[cod a] ⋅ (a ⊗ 𝟭) = a ⋅ 𝗋[dom a]"
using assms pr_naturality(2) ide_char ide_one by blast
lemma inverse_arrows_runit:
assumes "ide a"
shows "inverse_arrows 𝗋[a] 𝗋⇧-⇧1[a]"
proof
show "ide (𝗋[a] ⋅ 𝗋⇧-⇧1[a])"
proof -
have "𝗋[a] ⋅ 𝗋⇧-⇧1[a] = a"
using assms
by (metis in_homE ide_char pr_tuple(1) trm_in_hom)
thus ?thesis
using assms by presburger
qed
show "ide (𝗋⇧-⇧1[a] ⋅ 𝗋[a])"
proof -
have "ide (a ⊗ 𝟭)"
using assms ide_one by blast
moreover have "𝗋⇧-⇧1[a] ⋅ 𝗋[a] = a ⊗ 𝟭"
proof (intro pr_joint_monic [of a 𝟭 "𝗋⇧-⇧1[a] ⋅ 𝗋[a]" "a ⊗ 𝟭"])
show "seq 𝔭⇩0[a, 𝟭] (𝗋⇧-⇧1[a] ⋅ 𝗋[a])"
using assms ide_one runit'_in_hom [of a]
by (intro seqI) auto
show "𝔭⇩0[a, 𝟭] ⋅ 𝗋⇧-⇧1[a] ⋅ 𝗋[a] = 𝔭⇩0[a, 𝟭] ⋅ (a ⊗ 𝟭)"
proof -
have "𝔭⇩0[a, 𝟭] ⋅ 𝗋⇧-⇧1[a] ⋅ 𝗋[a] = (𝔭⇩0[a, 𝟭] ⋅ 𝗋⇧-⇧1[a]) ⋅ 𝗋[a]"
using comp_assoc by simp
also have "... = 𝗍[a] ⋅ 𝗋[a]"
using assms ide_one
by (metis in_homE pr_tuple(2) ide_char trm_in_hom)
also have "... = 𝗍[a ⊗ 𝟭]"
using assms ide_one trm_naturality [of "𝗋[a]"] by simp
also have "... = 𝔭⇩0[a, 𝟭] ⋅ (a ⊗ 𝟭)"
using assms comp_arr_dom ide_one trm_naturality trm_one by fastforce
finally show ?thesis by blast
qed
show "𝔭⇩1[a, 𝟭] ⋅ 𝗋⇧-⇧1[a] ⋅ 𝗋[a] = 𝔭⇩1[a, 𝟭] ⋅ (a ⊗ 𝟭)"
using assms
by (metis ‹ide (𝗋[a] ⋅ 𝗋⇧-⇧1[a])› cod_comp cod_pr1 dom_comp ide_compE ide_one
comp_assoc runit_naturality)
qed
ultimately show ?thesis by simp
qed
qed
lemma lunit_naturality:
assumes "arr f"
shows "C 𝗅[cod f] (𝟭 ⊗ f) = C f 𝗅[dom f]"
using assms pr_naturality(1) ide_char ide_one by blast
lemma inverse_arrows_lunit:
assumes "ide a"
shows "inverse_arrows 𝗅[a] 𝗅⇧-⇧1[a]"
proof
show "ide (C 𝗅[a] 𝗅⇧-⇧1[a])"
proof -
have "C 𝗅[a] 𝗅⇧-⇧1[a] = a"
using assms
by (metis ide_char in_homE pr_tuple(2) trm_in_hom)
thus ?thesis
using assms by simp
qed
show "ide (𝗅⇧-⇧1[a] ⋅ 𝗅[a])"
proof -
have "𝗅⇧-⇧1[a] ⋅ 𝗅[a] = 𝟭 ⊗ a"
proof (intro pr_joint_monic [of 𝟭 a "𝗅⇧-⇧1[a] ⋅ 𝗅[a]" "𝟭 ⊗ a"])
show "seq 𝗅[a] (𝗅⇧-⇧1[a] ⋅ 𝗅[a])"
using assms ‹ide (𝗅[a] ⋅ 𝗅⇧-⇧1[a])› by blast
show "𝗅[a] ⋅ 𝗅⇧-⇧1[a] ⋅ 𝗅[a] = 𝗅[a] ⋅ (𝟭 ⊗ a)"
using assms
by (metis ‹ide (𝗅[a] ⋅ 𝗅⇧-⇧1[a])› cod_comp cod_pr0 dom_cod ide_compE ide_one
comp_assoc lunit_naturality)
show "𝔭⇩1[𝟭, a] ⋅ 𝗅⇧-⇧1[a] ⋅ 𝗅[a] = 𝔭⇩1[𝟭, a] ⋅ (𝟭 ⊗ a)"
proof -
have "𝔭⇩1[𝟭, a] ⋅ 𝗅⇧-⇧1[a] ⋅ 𝗅[a] = (𝔭⇩1[𝟭, a] ⋅ 𝗅⇧-⇧1[a]) ⋅ 𝗅[a]"
using comp_assoc by simp
also have "... = 𝗍[a] ⋅ 𝗅[a]"
using assms ide_one
by (metis pr_tuple(1) ide_char in_homE trm_in_hom)
also have "... = 𝗍[𝟭 ⊗ a]"
using assms ide_one trm_naturality [of "𝗅[a]"] by simp
also have "... = 𝔭⇩1[𝟭, a] ⋅ (𝟭 ⊗ a)"
using assms comp_arr_dom ide_one trm_naturality trm_one by fastforce
finally show ?thesis by simp
qed
qed
moreover have "ide (𝟭 ⊗ a)"
using assms ide_one by simp
finally show ?thesis by blast
qed
qed
lemma comp_lunit_term_dup:
assumes "ide a"
shows "𝗅[a] ⋅ (𝗍[a] ⊗ a) ⋅ 𝖽[a] = a"
proof -
have "«𝗍[a] : a → 𝟭»"
using assms trm_in_hom by blast
hence "𝗅[a] ⋅ (𝗍[a] ⊗ a) = a ⋅ 𝔭⇩0[a, a]"
by (metis assms pr_naturality(1) ide_char in_homE)
thus ?thesis
by (metis (no_types) assms comp_assoc comp_ide_self pr_dup(1))
qed
lemma comp_runit_term_dup:
assumes "ide a"
shows "𝗋[a] ⋅ (a ⊗ 𝗍[a]) ⋅ 𝖽[a] = a"
proof -
have "«𝗍[a] : a → 𝟭»"
using assms trm_in_hom by blast
hence "𝗋[a] ⋅ (a ⊗ 𝗍[a]) = a ⋅ 𝔭⇩1[a, a]"
using assms by auto
thus ?thesis
using assms
by (metis comp_ide_arr pr_dup(2) ide_char comp_assoc seqI)
qed
lemma comp_proj_assoc:
assumes "ide a0" and "ide a1" and "ide a2"
shows "𝔭⇩1[a0, a1 ⊗ a2] ⋅ 𝖺[a0, a1, a2] = 𝔭⇩1[a0, a1] ⋅ 𝔭⇩1[a0 ⊗ a1, a2]"
and "𝔭⇩0[a0, a1 ⊗ a2] ⋅ 𝖺[a0, a1, a2] = ⟨𝔭⇩0[a0, a1] ⋅ 𝔭⇩1[a0 ⊗ a1, a2], 𝔭⇩0[a0 ⊗ a1, a2]⟩"
using assms assoc_def by auto
lemma dup_coassoc:
assumes "ide a"
shows "𝖺[a, a, a] ⋅ (𝖽[a] ⊗ a) ⋅ 𝖽[a] = (a ⊗ 𝖽[a]) ⋅ 𝖽[a]"
proof (intro pr_joint_monic
[of a "a ⊗ a" "𝖺[a, a, a] ⋅ (𝖽[a] ⊗ a) ⋅ 𝖽[a]" "(a ⊗ 𝖽[a]) ⋅ 𝖽[a]"])
show "seq 𝔭⇩0[a, a ⊗ a] (𝖺[a, a, a] ⋅ (𝖽[a] ⊗ a) ⋅ 𝖽[a])"
using assms by simp
show "𝔭⇩0[a, a ⊗ a] ⋅ 𝖺[a, a, a] ⋅ (𝖽[a] ⊗ a) ⋅ 𝖽[a] = 𝔭⇩0[a, a ⊗ a] ⋅ (a ⊗ 𝖽[a]) ⋅ 𝖽[a]"
proof -
have "𝔭⇩0[a, a ⊗ a] ⋅ 𝖺[a, a, a] ⋅ (𝖽[a] ⊗ a) ⋅ 𝖽[a] =
((𝔭⇩0[a, a ⊗ a] ⋅ 𝖺[a, a, a]) ⋅ (𝖽[a] ⊗ a)) ⋅ 𝖽[a]"
using comp_assoc by simp
also have "... = ⟨((𝔭⇩0[a, a] ⋅ 𝔭⇩1[a ⊗ a, a]) ⋅ (𝖽[a] ⊗ a)) ⋅ 𝖽[a], (a ⋅ 𝔭⇩0[a, a]) ⋅ 𝖽[a]⟩"
using assms assoc_def by simp
also have "... = 𝖽[a]"
using assms comp_assoc by simp
also have "... = (𝔭⇩0[a, a ⊗ a] ⋅ (a ⊗ 𝖽[a])) ⋅ 𝖽[a]"
using assms assoc_def comp_assoc by simp
also have "... = 𝔭⇩0[a, a ⊗ a] ⋅ (a ⊗ 𝖽[a]) ⋅ 𝖽[a]"
using comp_assoc by simp
finally show ?thesis by blast
qed
show "𝔭⇩1[a, a ⊗ a] ⋅ 𝖺[a, a, a] ⋅ (𝖽[a] ⊗ a) ⋅ 𝖽[a] = 𝔭⇩1[a, a ⊗ a] ⋅ (a ⊗ 𝖽[a]) ⋅ 𝖽[a]"
proof -
have "𝔭⇩1[a, a ⊗ a] ⋅ 𝖺[a, a, a] ⋅ (𝖽[a] ⊗ a) ⋅ 𝖽[a] =
((𝔭⇩1[a, a ⊗ a] ⋅ 𝖺[a, a, a]) ⋅ (𝖽[a] ⊗ a)) ⋅ 𝖽[a]"
using comp_assoc by simp
also have "... = ((𝔭⇩1[a, a] ⋅ 𝔭⇩1[a ⊗ a, a]) ⋅ (𝖽[a] ⊗ a)) ⋅ 𝖽[a]"
using assms assoc_def by simp
also have "... = a"
using assms comp_assoc by simp
also have "... = (a ⋅ 𝔭⇩1[a, a]) ⋅ 𝖽[a]"
using assms comp_assoc by simp
also have "... = (𝔭⇩1[a, a ⊗ a] ⋅ (a ⊗ 𝖽[a])) ⋅ 𝖽[a]"
using assms by simp
also have "... = 𝔭⇩1[a, a ⊗ a] ⋅ (a ⊗ 𝖽[a]) ⋅ 𝖽[a]"
using comp_assoc by simp
finally show ?thesis by blast
qed
qed
lemma comp_assoc_tuple:
assumes "«f0 : a → b0»" and "«f1 : a → b1»" and "«f2 : a → b2»"
shows "𝖺[b0, b1, b2] ⋅ ⟨⟨f0, f1⟩, f2⟩ = ⟨f0, ⟨f1, f2⟩⟩"
and "𝖺⇧-⇧1[b0, b1, b2] ⋅ ⟨f0, ⟨f1, f2⟩⟩ = ⟨⟨f0, f1⟩, f2⟩"
using assms assoc_def assoc'_def comp_assoc by fastforce+
lemma dup_tensor:
assumes "ide a" and "ide b"
shows "𝖽[a ⊗ b] = 𝖺⇧-⇧1[a, b, a ⊗ b] ⋅ (a ⊗ 𝖺[b, a, b]) ⋅ (a ⊗ σ (a, b) ⊗ b) ⋅
(a ⊗ 𝖺⇧-⇧1[a, b, b]) ⋅ 𝖺[a, a, b ⊗ b] ⋅ (𝖽[a] ⊗ 𝖽[b])"
proof (intro pr_joint_monic [of "a ⊗ b" "a ⊗ b" "𝖽[a ⊗ b]"])
show "seq 𝔭⇩0[a ⊗ b, a ⊗ b] (𝖽[a ⊗ b])"
using assms by simp
have 1: "𝖺⇧-⇧1[a, b, a ⊗ b] ⋅ (a ⊗ 𝖺[b, a, b]) ⋅ (a ⊗ σ (a, b) ⊗ b) ⋅
(a ⊗ 𝖺⇧-⇧1[a, b, b]) ⋅ 𝖺[a, a, b ⊗ b] ⋅ (𝖽[a] ⊗ 𝖽[b]) =
⟨a ⊗ b, a ⊗ b⟩"
proof -
have "𝖺⇧-⇧1[a, b, a ⊗ b] ⋅ (a ⊗ 𝖺[b, a, b]) ⋅ (a ⊗ σ (a, b) ⊗ b) ⋅
(a ⊗ 𝖺⇧-⇧1[a, b, b]) ⋅ 𝖺[a, a, b ⊗ b] ⋅ (𝖽[a] ⊗ 𝖽[b])
= 𝖺⇧-⇧1[a, b, a ⊗ b] ⋅ (a ⊗ 𝖺[b, a, b]) ⋅ (a ⊗ σ (a, b) ⊗ b) ⋅
(a ⊗ 𝖺⇧-⇧1[a, b, b]) ⋅ ⟨𝔭⇩1[a, b], ⟨𝔭⇩1[a, b], 𝖽[b] ⋅ 𝔭⇩0[a, b]⟩⟩"
proof -
have "𝖺[a, a, b ⊗ b] ⋅ (𝖽[a] ⊗ 𝖽[b]) = ⟨𝔭⇩1[a, b], ⟨𝔭⇩1[a, b], 𝖽[b] ⋅ 𝔭⇩0[a, b]⟩⟩"
using assms assoc_def comp_assoc pr_naturality comp_cod_arr by simp
thus ?thesis by presburger
qed
also have "... = 𝖺⇧-⇧1[a, b, a ⊗ b] ⋅
⟨a ⋅ a ⋅ a ⋅ 𝔭⇩1[a, b], 𝖺[b, a, b] ⋅ (𝗌[a, b] ⋅ (a ⊗ b) ⊗ b) ⋅
𝖺⇧-⇧1[a, b, b] ⋅ ⟨𝔭⇩1[a, b], 𝖽[b ⋅ 𝔭⇩0[a, b]]⟩⟩"
using assms prod_tuple by simp
also have "... = 𝖺⇧-⇧1[a, b, a ⊗ b] ⋅
⟨𝔭⇩1[a, b], 𝖺[b, a, b] ⋅ (𝗌[a, b] ⊗ b) ⋅ 𝖺⇧-⇧1[a, b, b] ⋅ ⟨𝔭⇩1[a, b], 𝖽[𝔭⇩0[a, b]]⟩⟩"
proof -
have "a ⋅ a ⋅ a ⋅ 𝔭⇩1[a, b] = 𝔭⇩1[a, b]"
using assms comp_cod_arr by simp
moreover have "b ⋅ 𝔭⇩0[a, b] = 𝔭⇩0[a, b]"
using assms comp_cod_arr by simp
moreover have "𝗌[a, b] ⋅ (a ⊗ b) ⊗ b = 𝗌[a, b] ⊗ b"
using assms comp_arr_dom by simp
ultimately show ?thesis by simp
qed
also have "... = 𝖺⇧-⇧1[a, b, a ⊗ b] ⋅ ⟨𝔭⇩1[a, b], 𝖺[b, a, b] ⋅ (𝗌[a, b] ⊗ b) ⋅
⟨⟨𝔭⇩1[a, b], 𝔭⇩0[a, b]⟩, 𝔭⇩0[a, b]⟩⟩"
proof -
have "𝖺⇧-⇧1[a, b, b] ⋅ ⟨𝔭⇩1[a, b], 𝖽[𝔭⇩0[a, b]]⟩ = ⟨⟨𝔭⇩1[a, b], 𝔭⇩0[a, b]⟩, 𝔭⇩0[a, b]⟩"
using assms comp_assoc_tuple(2) by blast
thus ?thesis by simp
qed
also have "... = 𝖺⇧-⇧1[a, b, a ⊗ b] ⋅ ⟨𝔭⇩1[a, b], 𝖺[b, a, b] ⋅ ⟨𝗌[a, b], 𝔭⇩0[a, b]⟩⟩"
using assms prod_tuple comp_arr_dom comp_cod_arr by simp
also have "... = 𝖺⇧-⇧1[a, b, a ⊗ b] ⋅ ⟨𝔭⇩1[a, b], ⟨𝔭⇩0[a, b], ⟨𝔭⇩1[a, b], 𝔭⇩0[a, b]⟩⟩⟩"
using assms comp_assoc_tuple(1)
by (metis sym_def pr_in_hom)
also have "... = ⟨⟨𝔭⇩1[a, b], 𝔭⇩0[a, b]⟩, ⟨𝔭⇩1[a, b], 𝔭⇩0[a, b]⟩⟩"
using assms comp_assoc_tuple(2) by force
also have "... = 𝖽[a ⊗ b]"
using assms by simp
finally show ?thesis by simp
qed
show "𝔭⇩0[a ⊗ b, a ⊗ b] ⋅ 𝖽[a ⊗ b]
= 𝔭⇩0[a ⊗ b, a ⊗ b] ⋅
𝖺⇧-⇧1[a, b, a ⊗ b] ⋅ (a ⊗ 𝖺[b, a, b]) ⋅ (a ⊗ σ (a, b) ⊗ b) ⋅
(a ⊗ 𝖺⇧-⇧1[a, b, b]) ⋅ 𝖺[a, a, b ⊗ b] ⋅ (𝖽[a] ⊗ 𝖽[b])"
using assms 1 by force
show "𝔭⇩1[a ⊗ b, a ⊗ b] ⋅ 𝖽[a ⊗ b]
= 𝔭⇩1[a ⊗ b, a ⊗ b] ⋅
𝖺⇧-⇧1[a, b, a ⊗ b] ⋅ (a ⊗ 𝖺[b, a, b]) ⋅ (a ⊗ σ (a, b) ⊗ b) ⋅
(a ⊗ 𝖺⇧-⇧1[a, b, b]) ⋅ 𝖺[a, a, b ⊗ b] ⋅ (𝖽[a] ⊗ 𝖽[b])"
using assms 1 by force
qed
lemma ι_eq_trm:
shows "ι = 𝗍[𝟭 ⊗ 𝟭]"
proof (intro terminal_arr_unique)
show "par ι 𝗍[𝟭 ⊗ 𝟭]"
by (simp add: ide_one trm_one trm_tensor)
show "terminal_arr 𝗍[𝟭 ⊗ 𝟭]"
using ide_one ι_is_terminal_arr ‹par ι 𝗍[𝟭 ⊗ 𝟭]› by auto
show "terminal_arr ι"
using ι_is_terminal_arr by blast
qed
lemma terminal_tensor_one_one:
shows "terminal (𝟭 ⊗ 𝟭)"
proof
show "ide (𝟭 ⊗ 𝟭)"
using ide_one by simp
show "⋀a. ide a ⟹ ∃!f. «f : a → 𝟭 ⊗ 𝟭»"
proof -
fix a
assume a: "ide a"
show "∃!f. «f : a → 𝟭 ⊗ 𝟭»"
proof
show "«inv ι ⋅ 𝗍[a] : a → 𝟭 ⊗ 𝟭»"
using a ide_one inverse_arrows_ι inverse_unique trm_in_hom by fastforce
show "⋀f. «f : a → 𝟭 ⊗ 𝟭» ⟹ f = inv ι ⋅ 𝗍[a]"
proof -
fix f
assume f: "«f : a → 𝟭 ⊗ 𝟭»"
have "ι ⋅ f = 𝗍[a]"
proof (intro terminal_arr_unique)
show "par (ι ⋅ f) 𝗍[a]"
using a f
by (metis ι_is_iso ι_is_terminal_arr ‹«inv ι ⋅ 𝗍[a] : a → 𝟭 ⊗ 𝟭»›
cod_comp dom_comp dom_inv ide_one in_homE pr_simps(2-3) seqE seqI)
show "terminal_arr (ι ⋅ f)"
using a f ι_is_terminal_arr cod_comp by force
show "terminal_arr 𝗍[a]"
using a ‹par (ι ⋅ f) 𝗍[a]› ‹terminal_arr (ι ⋅ f)› by auto
qed
thus "f = inv ι ⋅ 𝗍[a]"
using a f ι_is_iso invert_side_of_triangle(1)
‹«inv ι ⋅ 𝗍[a] : a → 𝟭 ⊗ 𝟭»›
by blast
qed
qed
qed
qed
end
section "Category with Finite Products"
text ‹
In this last section, we show that the notion ``cartesian category'', which we defined
to be a category with binary products and terminal object, coincides with the notion
``category with finite products''. Due to the inability to quantify over types in HOL,
we content ourselves with defining the latter notion as "has ‹I›-indexed products
for every finite set ‹I› of natural numbers." We can transfer this property to finite
sets at other types using the fact that products are preserved under bijections of
the index sets.
›
locale category_with_finite_products =
category C
for C :: "'c comp" +
assumes has_finite_products: "finite (I :: nat set) ⟹ has_products I"
begin
lemma has_finite_products':
assumes "I ≠ UNIV"
shows "finite I ⟹ has_products I"
proof -
assume I: "finite I"
obtain n φ where φ: "bij_betw φ {k. k < (n :: nat)} I"
using I finite_imp_nat_seg_image_inj_on inj_on_imp_bij_betw by fastforce
show "has_products I"
using assms(1) φ has_finite_products has_products_preserved_by_bijection
category_with_finite_products.has_finite_products
by blast
qed
end
lemma (in category) has_binary_products_if:
assumes "has_products ({0, 1} :: nat set)"
shows "has_binary_products"
proof (unfold has_binary_products_def)
show "∀a0 a1. ide a0 ∧ ide a1 ⟶ (∃p0 p1. has_as_binary_product a0 a1 p0 p1)"
proof (intro allI impI)
fix a0 a1
assume 1: "ide a0 ∧ ide a1"
show "∃p0 p1. has_as_binary_product a0 a1 p0 p1"
proof -
interpret J: binary_product_shape
by unfold_locales
interpret D: binary_product_diagram C a0 a1
using 1 by unfold_locales auto
interpret discrete_diagram J.comp C D.map
using J.is_discrete
by unfold_locales auto
show "∃p0 p1. has_as_binary_product a0 a1 p0 p1"
proof (unfold has_as_binary_product_def)
text ‹
Here we have to work around the fact that ‹has_finite_products› is defined
in terms of @{typ "nat set"}, whereas ‹has_as_binary_product› is defined
in terms of ‹J.arr set›.
›
let ?φ = "(λx :: nat. if x = 0 then J.FF else J.TT)"
let ?ψ = "λj. if j = J.FF then 0 else 1"
have "bij_betw ?φ ({0, 1} :: nat set) {J.FF, J.TT}"
using bij_betwI [of ?φ "{0, 1} :: nat set" "{J.FF, J.TT}" ?ψ] by fastforce
hence "has_products {J.FF, J.TT}"
using assms has_products_def [of "{J.FF, J.TT}"]
has_products_preserved_by_bijection
[of "{0, 1} :: nat set" ?φ "{J.FF, J.TT}"]
by blast
hence "∃a. has_as_product J.comp D.map a"
using has_products_def [of "{J.FF, J.TT}"]
discrete_diagram_axioms J.arr_char
by blast
hence "∃a π. product_cone J.comp C D.map a π"
using has_as_product_def by blast
hence 2: "∃a π. D.limit_cone a π"
unfolding product_cone_def by simp
obtain a π where π: "D.limit_cone a π"
using 2 by auto
interpret π: limit_cone J.comp C D.map a π
using π by auto
have "π = D.mkCone (π J.FF) (π J.TT)"
proof -
have "⋀a. J.ide a ⟹ π a = D.mkCone (π J.FF) (π J.TT) a"
using D.mkCone_def J.ide_char by auto
moreover have "a = dom (π J.FF)"
by simp
moreover have "D.cone a (D.mkCone (π (J.MkIde False)) (π (J.MkIde True)))"
using 1 D.cone_mkCone [of "π J.FF" "π J.TT"] by auto
ultimately show ?thesis
using D.mkCone_def π.natural_transformation_axioms
D.cone_mkCone [of "π J.FF" "π J.TT"]
NaturalTransformation.eqI
[of "J.comp" C π.A.map "D.map" π "D.mkCone (π J.FF) (π J.TT)"]
cone_def [of J.comp C D.map a "D.mkCone (π J.FF) (π J.TT)"] J.ide_char
by blast
qed
hence "D.limit_cone (dom (π J.FF)) (D.mkCone (π J.FF) (π J.TT))"
using π.limit_cone_axioms by simp
thus "∃p0 p1. ide a0 ∧ ide a1 ∧ D.has_as_binary_product p0 p1"
using 1 by blast
qed
qed
qed
qed
sublocale category_with_finite_products ⊆ category_with_binary_products C
using has_binary_products_if has_finite_products
by (unfold_locales, unfold has_binary_products_def) simp
proposition (in category_with_finite_products) is_category_with_binary_products:
shows "category_with_binary_products C"
..
sublocale category_with_finite_products ⊆ category_with_terminal_object C
proof
interpret J: discrete_category "{} :: nat set"
by unfold_locales auto
interpret D: empty_diagram J.comp C "λj. null"
by unfold_locales auto
interpret D: discrete_diagram J.comp C "λj. null"
using J.is_discrete by unfold_locales auto
have "⋀a. D.has_as_limit a ⟷ has_as_product J.comp (λj. null) a"
using product_cone_def J.category_axioms category_axioms D.discrete_diagram_axioms
has_as_product_def product_cone_def
by metis
moreover have "∃a. has_as_product J.comp (λj. null) a"
using has_finite_products [of "{} :: nat set"] has_products_def [of "{} :: nat set"]
D.discrete_diagram_axioms
by blast
ultimately have "∃a. D.has_as_limit a" by blast
thus "∃a. terminal a" using D.has_as_limit_iff_terminal by blast
qed
proposition (in category_with_finite_products) is_category_with_terminal_object:
shows "category_with_terminal_object C"
..
sublocale category_with_finite_products ⊆ cartesian_category ..
proposition (in category_with_finite_products) is_cartesian_category:
shows "cartesian_category C"
..
context category
begin
lemma binary_product_of_products_is_product:
assumes "has_as_product J0 D0 a0" and "has_as_product J1 D1 a1"
and "has_as_binary_product a0 a1 p0 p1"
and "Collect (partial_magma.arr J0) ∩ Collect (partial_magma.arr J1) = {}"
and "partial_magma.null J0 = partial_magma.null J1"
shows "has_as_product
(discrete_category.comp
(Collect (partial_magma.arr J0) ∪ Collect (partial_magma.arr J1))
(partial_magma.null J0))
(λi. if i ∈ Collect (partial_magma.arr J0) then D0 i
else if i ∈ Collect (partial_magma.arr J1) then D1 i
else null)
(dom p0)"
proof -
obtain π0 where π0: "product_cone J0 (⋅) D0 a0 π0"
using assms(1) has_as_product_def by blast
obtain π1 where π1: "product_cone J1 (⋅) D1 a1 π1"
using assms(2) has_as_product_def by blast
interpret J0: category J0
using π0 product_cone.axioms(1) by metis
interpret J1: category J1
using π1 product_cone.axioms(1) by metis
interpret D0: discrete_diagram J0 C D0
using π0 product_cone.axioms(3) by metis
interpret D1: discrete_diagram J1 C D1
using π1 product_cone.axioms(3) by metis
interpret π0: product_cone J0 C D0 a0 π0
using π0 by auto
interpret π1: product_cone J1 C D1 a1 π1
using π1 by auto
interpret J: discrete_category ‹Collect J0.arr ∪ Collect J1.arr› J0.null
using J0.not_arr_null assms(5) by unfold_locales auto
interpret X: binary_product_shape .
interpret a0xa1: binary_product_diagram C a0 a1
using assms(3) has_as_binary_product_def
by (simp add: binary_product_diagram.intro binary_product_diagram_axioms.intro
category_axioms)
have p0p1: "a0xa1.has_as_binary_product p0 p1"
using assms(3) has_as_binary_product_def [of a0 a1 p0 p1] by simp
let ?D = "(λi. if i ∈ Collect J0.arr then D0 i
else if i ∈ Collect J1.arr then D1 i
else null)"
let ?a = "dom p0"
let ?π = "λi. if i ∈ Collect J0.arr then π0 i ⋅ p0
else if i ∈ Collect J1.arr then π1 i ⋅ p1
else null"
let ?p0p1 = "a0xa1.mkCone p0 p1"
interpret p0p1: limit_cone X.comp C a0xa1.map ?a ?p0p1
using p0p1 by simp
have a: "ide ?a"
using p0p1.ide_apex by simp
have p0: "«p0 : ?a → a0»"
using a0xa1.mkCone_def p0p1.preserves_hom [of X.FF X.FF X.FF] X.ide_char X.ide_in_hom
by auto
have p1: "«p1 : ?a → a1»"
using a0xa1.mkCone_def p0p1.preserves_hom [of X.TT X.TT X.TT] X.ide_char X.ide_in_hom
by auto
interpret D: discrete_diagram J.comp C ?D
using assms J.arr_char J.dom_char J.cod_char J.is_discrete D0.is_discrete D1.is_discrete
J.cod_comp J.seq_char
by unfold_locales auto
interpret A: constant_functor J.comp C ?a
using p0p1.ide_apex by unfold_locales simp
interpret π: natural_transformation J.comp C A.map ?D ?π
proof
fix j
show "¬ J.arr j ⟹ ?π j = null"
by simp
assume j: "J.arr j"
have π0j: "J0.arr j ⟹ «π0 j : a0 → D0 j»"
using D0.is_discrete by auto
have π1j: "J1.arr j ⟹ «π1 j : a1 → D1 j»"
using D1.is_discrete by auto
show "dom (?π j) = A.map (J.dom j)"
using j J.arr_char p0 p1 π0j π1j
by fastforce
show "cod (?π j) = ?D (J.cod j)"
using j J.arr_char p0 p1 π0j π1j
by fastforce
show "?D j ⋅ ?π (J.dom j) = ?π j"
proof -
have 0: "J0.arr j ⟹ D0 j ⋅ π0 j ⋅ p0 = π0 j ⋅ p0"
proof -
have "J0.arr j ⟹ (D0 j ⋅ π0 j) ⋅ p0 = π0 j ⋅ p0"
using p0 π0.is_natural_1 π0.is_natural_2 D0.is_discrete by simp
thus "J0.arr j ⟹ D0 j ⋅ π0 j ⋅ p0 = π0 j ⋅ p0"
using comp_assoc by simp
qed
have 1: "J1.arr j ⟹ D1 j ⋅ π1 j ⋅ p1 = π1 j ⋅ p1"
proof -
have "J1.arr j ⟹ (D1 j ⋅ π1 j) ⋅ p1 = π1 j ⋅ p1"
using p1 π1.is_natural_1 π1.is_natural_2 D1.is_discrete by simp
thus "J1.arr j ⟹ D1 j ⋅ π1 j ⋅ p1 = π1 j ⋅ p1"
using comp_assoc by simp
qed
show ?thesis
using 0 1 by auto
qed
show "?π (J.cod j) ⋅ A.map j = ?π j"
using j comp_arr_dom p0 p1 comp_assoc by auto
qed
interpret π: cone J.comp C ?D ?a ?π ..
interpret π: product_cone J.comp C ?D ?a ?π
proof
show "⋀a' χ'. D.cone a' χ' ⟹ ∃!f. «f : a' → ?a» ∧ D.cones_map f ?π = χ'"
proof -
fix a' χ'
assume χ': "D.cone a' χ'"
interpret χ': cone J.comp C ?D a' χ'
using χ' by simp
show "∃!f. «f : a' → ?a» ∧ D.cones_map f ?π = χ'"
proof
let ?χ0' = "λi. if i ∈ Collect J0.arr then χ' i else null"
let ?χ1' = "λi. if i ∈ Collect J1.arr then χ' i else null"
have 0: "⋀i. i ∈ Collect J0.arr ⟹ χ' i ∈ hom a' (D0 i)"
using J.arr_char by auto
have 1: "⋀i. i ∈ Collect J1.arr ⟹ χ' i ∈ hom a' (D1 i)"
using J.arr_char ‹Collect J0.arr ∩ Collect J1.arr = {}› by force
interpret A0': constant_functor J0 C a'
apply unfold_locales using χ'.ide_apex by auto
interpret A1': constant_functor J1 C a'
apply unfold_locales using χ'.ide_apex by auto
interpret χ0': cone J0 C D0 a' ?χ0'
proof (unfold_locales)
fix j
show "¬ J0.arr j ⟹ (if j ∈ Collect J0.arr then χ' j else null) = null"
by simp
assume j: "J0.arr j"
show 0: "dom (?χ0' j) = A0'.map (J0.dom j)"
using j by simp
show 1: "cod (?χ0' j) = D0 (J0.cod j)"
using j J.arr_char J.cod_char D0.is_discrete by simp
show "D0 j ⋅ (?χ0' (J0.dom j)) = ?χ0' j"
using 1 j J.arr_char D0.is_discrete comp_cod_arr by simp
show "?χ0' (J0.cod j) ⋅ A0'.map j = ?χ0' j"
using 0 j J.arr_char D0.is_discrete comp_arr_dom by simp
qed
interpret χ1': cone J1 C D1 a' ?χ1'
proof (unfold_locales)
fix j
show "¬ J1.arr j ⟹ (if j ∈ Collect J1.arr then χ' j else null) = null"
by simp
assume j: "J1.arr j"
show 0: "dom (?χ1' j) = A1'.map (J1.dom j)"
using j by simp
show 1: "cod (?χ1' j) = D1 (J1.cod j)"
using assms(4) j J.arr_char J.cod_char D1.is_discrete by auto
show "D1 j ⋅ (?χ1' (J1.dom j)) = ?χ1' j"
using 1 j J.arr_char D1.is_discrete comp_cod_arr by simp
show "?χ1' (J1.cod j) ⋅ A1'.map j = ?χ1' j"
using 0 j J.arr_char D1.is_discrete comp_arr_dom by simp
qed
define f0 where "f0 = π0.induced_arrow a' ?χ0'"
define f1 where "f1 = π1.induced_arrow a' ?χ1'"
have f0: "«f0 : a' → a0»"
using f0_def π0.induced_arrowI χ0'.cone_axioms by simp
have f1: "«f1 : a' → a1»"
using f1_def π1.induced_arrowI χ1'.cone_axioms by simp
have 2: "a0xa1.is_rendered_commutative_by f0 f1"
using f0 f1 by auto
interpret p0p1: binary_product_cone C a0 a1 p0 p1 ..
interpret f0f1: cone X.comp C a0xa1.map a' ‹a0xa1.mkCone f0 f1›
using 2 f0 f1 a0xa1.cone_mkCone [of f0 f1] by auto
define f where "f = p0p1.induced_arrow a' (a0xa1.mkCone f0 f1)"
have f: "«f : a' → ?a»"
using f_def 2 f0 f1 p0p1.induced_arrowI'(1) by auto
moreover have χ': "D.cones_map f ?π = χ'"
proof
fix j
show "D.cones_map f ?π j = χ' j"
proof (cases "J0.arr j", cases "J1.arr j")
show "⟦J0.arr j; J1.arr j⟧ ⟹ D.cones_map f ?π j = χ' j"
using assms(4) by auto
show "⟦J0.arr j; ¬ J1.arr j⟧ ⟹ D.cones_map f ?π j = χ' j"
proof -
assume J0: "J0.arr j" and J1: "¬ J1.arr j"
have "D.cones_map f ?π j = (π0 j ⋅ p0) ⋅ f"
using f J0 J1 π.cone_axioms by auto
also have "... = π0 j ⋅ p0 ⋅ f"
using comp_assoc by simp
also have "... = π0 j ⋅ f0"
using 2 f0 f1 f_def p0p1.induced_arrowI' by auto
also have "... = χ' j"
proof -
have "π0 j ⋅ f0 = π0 j ⋅ π0.induced_arrow' a' χ'"
unfolding f0_def by simp
also have "... = (λj. if J0.arr j then
π0 j ⋅ π0.induced_arrow a'
(λi. if i ∈ Collect J0.arr then χ' i else null)
else null) j"
using J0 by simp
also have "... = D0.mkCone χ' j"
proof -
have "(λj. if J0.arr j then
π0 j ⋅ π0.induced_arrow a'
(λi. if i ∈ Collect J0.arr then χ' i else null)
else null) =
D0.mkCone χ'"
using f0 f0_def π0.induced_arrowI(2) [of ?χ0' a'] J0
D0.mkCone_cone χ0'.cone_axioms π0.cone_axioms J0
by auto
thus ?thesis by meson
qed
also have "... = χ' j"
using J0 by simp
finally show ?thesis by blast
qed
finally show ?thesis by simp
qed
show "¬ J0.arr j ⟹ D.cones_map f ?π j = χ' j"
proof (cases "J1.arr j")
show "⟦¬ J0.arr j; ¬ J1.arr j⟧ ⟹ D.cones_map f ?π j = χ' j"
using f π.cone_axioms χ'.is_extensional by auto
show "⟦¬ J0.arr j; J1.arr j⟧ ⟹ D.cones_map f ?π j = χ' j"
proof -
assume J0: "¬ J0.arr j" and J1: "J1.arr j"
have "D.cones_map f ?π j = (π1 j ⋅ p1) ⋅ f"
using J0 J1 f π.cone_axioms by auto
also have "... = π1 j ⋅ p1 ⋅ f"
using comp_assoc by simp
also have "... = π1 j ⋅ f1"
using 2 f0 f1 f_def p0p1.induced_arrowI' by auto
also have "... = χ' j"
proof -
have "π1 j ⋅ f1 = π1 j ⋅ π1.induced_arrow' a' χ'"
unfolding f1_def by simp
also have "... = (λj. if J1.arr j then
π1 j ⋅ π1.induced_arrow a'
(λi. if i ∈ Collect J1.arr
then χ' i else null)
else null) j"
using J1 by simp
also have "... = D1.mkCone χ' j"
proof -
have "(λj. if J1.arr j then
π1 j ⋅ π1.induced_arrow a'
(λi. if i ∈ Collect J1.arr then χ' i else null)
else null) =
D1.mkCone χ'"
using f1 f1_def π1.induced_arrowI(2) [of ?χ1' a'] J1
D1.mkCone_cone [of a' χ'] χ1'.cone_axioms π1.cone_axioms J1
by auto
thus ?thesis by meson
qed
also have "... = χ' j"
using J1 by simp
finally show ?thesis by blast
qed
finally show ?thesis by simp
qed
qed
qed
qed
ultimately show "«f : a' → ?a» ∧ D.cones_map f ?π = χ'" by blast
show "⋀f'. «f' : a' → ?a» ∧ D.cones_map f' ?π = χ' ⟹ f' = f"
proof -
fix f'
assume f': "«f' : a' → ?a» ∧ D.cones_map f' ?π = χ'"
let ?f0' = "p0 ⋅ f'"
let ?f1' = "p1 ⋅ f'"
have 1: "a0xa1.is_rendered_commutative_by ?f0' ?f1'"
using f' p0 p1 p0p1.renders_commutative seqI' by auto
have f0': "«?f0' : a' → a0»"
using f' p0 by auto
have f1': "«?f1' : a' → a1»"
using f' p1 by auto
have "p0 ⋅ f = p0 ⋅ f'"
proof -
have "D0.cones_map (p0 ⋅ f) π0 = ?χ0'"
using f p0 π0.cone_axioms χ' π.cone_axioms comp_assoc assms(4) seqI'
by fastforce
moreover have "D0.cones_map (p0 ⋅ f') π0 = ?χ0'"
using f' p0 π0.cone_axioms π.cone_axioms comp_assoc assms(4) seqI'
by fastforce
moreover have "p0 ⋅ f = f0"
using 2 f0 f_def p0p1.induced_arrowI'(2) by blast
ultimately show ?thesis
using f0 f0' χ0'.cone_axioms π0.is_universal [of a'] by auto
qed
moreover have "p1 ⋅ f = p1 ⋅ f'"
proof -
have "D1.cones_map (p1 ⋅ f) π1 = ?χ1'"
proof
fix j
show "D1.cones_map (p1 ⋅ f) π1 j = ?χ1' j"
using f p1 π1.cone_axioms χ' π.cone_axioms comp_assoc assms(4) seqI'
apply auto
by auto
qed
moreover have "D1.cones_map (p1 ⋅ f') π1 = ?χ1'"
proof
fix j
show "D1.cones_map (p1 ⋅ f') π1 j = ?χ1' j"
using f' p1 π1.cone_axioms π.cone_axioms comp_assoc assms(4) seqI'
apply auto
by auto
qed
moreover have "p1 ⋅ f = f1"
using 2 f1 f_def p0p1.induced_arrowI'(3) by blast
ultimately show ?thesis
using f1 f1' χ1'.cone_axioms π1.is_universal [of a'] by auto
qed
ultimately show "f' = f"
using f f' p0p1.is_universal' [of a']
by (metis (no_types, lifting) "1" dom_comp in_homE p0p1.is_universal' p1 seqI')
qed
qed
qed
qed
show "has_as_product J.comp ?D ?a"
unfolding has_as_product_def
using π.product_cone_axioms by auto
qed
end
sublocale cartesian_category ⊆ category_with_finite_products
proof
obtain t where t: "terminal t" using has_terminal by blast
{ fix n :: nat
have "⋀I :: nat set. finite I ∧ card I = n ⟹ has_products I"
proof (induct n)
show "⋀I :: nat set. finite I ∧ card I = 0 ⟹ has_products I"
proof -
fix I :: "nat set"
assume "finite I ∧ card I = 0"
hence I: "I = {}" by force
thus "has_products I"
proof -
interpret J: discrete_category I 0
apply unfold_locales using I by auto
have "⋀D. discrete_diagram J.comp C D ⟹ ∃a. has_as_product J.comp D a"
proof -
fix D
assume D: "discrete_diagram J.comp C D"
interpret D: discrete_diagram J.comp C D using D by auto
interpret D: empty_diagram J.comp C D
using I J.arr_char by unfold_locales simp
have "has_as_product J.comp D t"
using t D.has_as_limit_iff_terminal has_as_product_def product_cone_def
J.category_axioms category_axioms D.discrete_diagram_axioms
by metis
thus "∃a. has_as_product J.comp D a" by blast
qed
moreover have "I ≠ UNIV"
using I by blast
ultimately show ?thesis
using I has_products_def
by (metis category_with_terminal_object.has_terminal discrete_diagram.product_coneI
discrete_diagram_def empty_diagram.has_as_limit_iff_terminal empty_diagram.intro
empty_diagram_axioms.intro empty_iff has_as_product_def
is_category_with_terminal_object mem_Collect_eq)
qed
qed
show "⋀n I :: nat set.
⟦ (⋀I :: nat set. finite I ∧ card I = n ⟹ has_products I);
finite I ∧ card I = Suc n ⟧
⟹ has_products I"
proof -
fix n :: nat
fix I :: "nat set"
assume IH: "⋀I :: nat set. finite I ∧ card I = n ⟹ has_products I"
assume I: "finite I ∧ card I = Suc n"
show "has_products I"
proof -
have "card I = 1 ⟹ has_products I"
using I has_unary_products by blast
moreover have "card I ≠ 1 ⟹ has_products I"
proof -
assume "card I ≠ 1"
hence cardI: "card I > 1" using I by simp
obtain i where i: "i ∈ I" using cardI by fastforce
let ?I0 = "{i}" and ?I1 = "I - {i}"
have 1: "I = ?I0 ∪ ?I1 ∧ ?I0 ∩ ?I1 = {} ∧ card ?I0 = 1 ∧ card ?I1 = n"
using i I cardI by auto
show "has_products I"
proof (unfold has_products_def, intro conjI allI impI)
show "I ≠ UNIV"
using I by auto
fix J D
assume D: "discrete_diagram J C D ∧ Collect (partial_magma.arr J) = I"
interpret D: discrete_diagram J C D
using D by simp
have Null: "D.J.null ∉ ?I0 ∧ D.J.null ∉ ?I1"
using D D.J.not_arr_null i by blast
interpret J0: discrete_category ?I0 D.J.null
using 1 Null D by unfold_locales auto
interpret J1: discrete_category ?I1 D.J.null
using Null by unfold_locales auto
interpret J0uJ1: discrete_category ‹Collect J0.arr ∪ Collect J1.arr› J0.null
using Null 1 J0.null_char J1.null_char by unfold_locales auto
interpret D0: discrete_diagram_from_map ?I0 C D D.J.null
using 1 J0.ide_char D.preserves_ide D D.is_discrete i by unfold_locales auto
interpret D1: discrete_diagram_from_map ?I1 C D D.J.null
using 1 J1.ide_char D.preserves_ide D D.is_discrete i by unfold_locales auto
obtain a0 where a0: "has_as_product J0.comp D0.map a0"
using 1 has_unary_products [of ?I0] has_products_def [of ?I0]
D0.discrete_diagram_axioms
by fastforce
obtain a1 where a1: "has_as_product J1.comp D1.map a1"
using 1 I IH [of ?I1] has_products_def [of ?I1] D1.discrete_diagram_axioms
by blast
have 2: "∃p0 p1. has_as_binary_product a0 a1 p0 p1"
proof -
have "ide a0 ∧ ide a1"
using a0 a1 product_is_ide by auto
thus ?thesis
using a0 a1 has_binary_products has_binary_products_def by simp
qed
obtain p0 p1 where a: "has_as_binary_product a0 a1 p0 p1"
using 2 by auto
let ?a = "dom p0"
have "has_as_product J D ?a"
proof -
have "D = (λj. if j ∈ Collect J0.arr then D0.map j
else if j ∈ Collect J1.arr then D1.map j
else null)"
proof
fix j
show "D j = (if j ∈ Collect J0.arr then D0.map j
else if j ∈ Collect J1.arr then D1.map j
else null)"
using 1 D0.map_def D1.map_def D.is_extensional D J0.arr_char J1.arr_char
by auto
qed
moreover have "J = J0uJ1.comp"
proof -
have "⋀j j'. J j j' = J0uJ1.comp j j'"
proof -
fix j j'
show "J j j' = J0uJ1.comp j j'"
using D J0uJ1.arr_char J0.arr_char J1.arr_char D.is_discrete i
apply (cases "j ∈ ?I0", cases "j' ∈ ?I0")
apply simp_all
apply auto[1]
apply (metis D.J.comp_arr_ide D.J.comp_ide_arr D.J.ext D.J.seqE
D.is_discrete J0.null_char J0uJ1.null_char)
by (metis D.J.comp_arr_ide D.J.comp_ide_arr D.J.comp_ide_self
D.J.ext D.J.seqE D.is_discrete J0.null_char J0uJ1.null_char
mem_Collect_eq)
qed
thus ?thesis by blast
qed
moreover have "Collect J0.arr ∩ Collect J1.arr = {}"
by auto
moreover have "J0.null = J1.null"
using J0.null_char J1.null_char by simp
ultimately show "has_as_product J D ?a"
using binary_product_of_products_is_product
[of J0.comp D0.map a0 J1.comp D1.map a1 p0 p1]
J0.arr_char J1.arr_char
1 a0 a1 a
by simp
qed
thus "∃a. has_as_product J D a" by blast
qed
qed
ultimately show "has_products I" by blast
qed
qed
qed
}
hence 1: "⋀n I :: nat set. finite I ∧ card I = n ⟹ has_products I" by simp
thus "⋀I :: nat set. finite I ⟹ has_products I" by blast
qed
proposition (in cartesian_category) is_category_with_finite_products:
shows "category_with_finite_products C"
..
end
Theory CategoryWithPullbacks
chapter "Category with Pullbacks"
theory CategoryWithPullbacks
imports Limit
begin
text ‹
\sloppypar
In this chapter, we give a traditional definition of pullbacks in a category as
limits of cospan diagrams and we define a locale ‹category_with_pullbacks› that
is satisfied by categories in which every cospan diagram has a limit.
These definitions build on the general definition of limit that we gave in
@{theory Category3.Limit}. We then define a locale ‹elementary_category_with_pullbacks›
that axiomatizes categories equipped with chosen functions that assign to each cospan
a corresponding span of ``projections'', which enjoy the familiar universal property
of a pullback. After developing consequences of the axioms, we prove that the two
locales are in agreement, in the sense that every interpretation of
‹category_with_pullbacks› extends to an interpretation of
‹elementary_category_with_pullbacks›, and conversely, the underlying category of
an interpretation of ‹elementary_category_with_pullbacks› always yields an interpretation
of ‹category_with_pullbacks›.
›
section "Commutative Squares"
context category
begin
text ‹
The following provides some useful technology for working with commutative squares.
›
definition commutative_square
where "commutative_square f g h k ≡ cospan f g ∧ span h k ∧ dom f = cod h ∧ f ⋅ h = g ⋅ k"
lemma commutative_squareI [intro, simp]:
assumes "cospan f g" and "span h k" and "dom f = cod h" and "f ⋅ h = g ⋅ k"
shows "commutative_square f g h k"
using assms commutative_square_def by auto
lemma commutative_squareE [elim]:
assumes "commutative_square f g h k"
and "⟦ arr f; arr g; arr h; arr k; cod f = cod g; dom h = dom k; dom f = cod h;
dom g = cod k; f ⋅ h = g ⋅ k ⟧ ⟹ T"
shows T
using assms commutative_square_def
by (metis (mono_tags, lifting) seqE seqI)
lemma commutative_square_comp_arr:
assumes "commutative_square f g h k" and "seq h l"
shows "commutative_square f g (h ⋅ l) (k ⋅ l)"
using assms
apply (elim commutative_squareE, intro commutative_squareI, auto)
using comp_assoc by metis
lemma arr_comp_commutative_square:
assumes "commutative_square f g h k" and "seq l f"
shows "commutative_square (l ⋅ f) (l ⋅ g) h k"
using assms comp_assoc
by (elim commutative_squareE, intro commutative_squareI, auto)
end
section "Cospan Diagrams"
text ‹
The ``shape'' of a cospan diagram is a category having two non-identity arrows
with distinct domains and a common codomain.
›
locale cospan_shape
begin
datatype Arr = Null | AA | BB | TT | AT | BT
fun comp
where "comp AA AA = AA"
| "comp AT AA = AT"
| "comp TT AT = AT"
| "comp BB BB = BB"
| "comp BT BB = BT"
| "comp TT BT = BT"
| "comp TT TT = TT"
| "comp _ _ = Null"
interpretation partial_magma comp
proof
show "∃!n. ∀f. comp n f = n ∧ comp f n = n"
proof
show "∀f. comp Null f = Null ∧ comp f Null = Null" by simp
show "⋀n. ∀f. comp n f = n ∧ comp f n = n ⟹ n = Null"
by (metis comp.simps(8))
qed
qed
lemma null_char:
shows "null = Null"
proof -
have "∀f. comp Null f = Null ∧ comp f Null = Null" by simp
thus ?thesis
using null_def ex_un_null theI [of "λn. ∀f. comp n f = n ∧ comp f n = n"]
by (metis partial_magma.comp_null(2) partial_magma_axioms)
qed
lemma ide_char:
shows "ide f ⟷ f = AA ∨ f = BB ∨ f = TT"
proof
show "ide f ⟹ f = AA ∨ f = BB ∨ f = TT"
using ide_def null_char by (cases f, simp_all)
show "f = AA ∨ f = BB ∨ f = TT ⟹ ide f"
proof -
have 1: "⋀f g. f = AA ∨ f = BB ∨ f = TT ⟹
comp f f ≠ Null ∧
(comp g f ≠ Null ⟶ comp g f = g) ∧
(comp f g ≠ Null ⟶ comp f g = g)"
proof -
fix f g
show "f = AA ∨ f = BB ∨ f = TT ⟹
comp f f ≠ Null ∧
(comp g f ≠ Null ⟶ comp g f = g) ∧
(comp f g ≠ Null ⟶ comp f g = g)"
by (cases f; cases g, auto)
qed
assume f: "f = AA ∨ f = BB ∨ f = TT"
show "ide f"
using f 1 ide_def null_char by simp
qed
qed
fun Dom
where "Dom AA = AA"
| "Dom BB = BB"
| "Dom TT = TT"
| "Dom AT = AA"
| "Dom BT = BB"
| "Dom _ = Null"
fun Cod
where "Cod AA = AA"
| "Cod BB = BB"
| "Cod TT = TT"
| "Cod AT = TT"
| "Cod BT = TT"
| "Cod _ = Null"
lemma domains_char':
shows "domains f = (if f = Null then {} else {Dom f})"
using domains_def ide_char null_char
by (cases f, auto)
lemma codomains_char':
shows "codomains f = (if f = Null then {} else {Cod f})"
using codomains_def ide_char null_char
by (cases f, auto)
lemma arr_char:
shows "arr f ⟷ f ≠ Null"
using arr_def domains_char' codomains_char' by simp
lemma seq_char:
shows "seq g f ⟷ (f = AA ∧ (g = AA ∨ g = AT)) ∨
(f = BB ∧ (g = BB ∨ g = BT)) ∨
(f = AT ∧ g = TT) ∨
(f = BT ∧ g = TT) ∨
(f = TT ∧ g = TT)"
using arr_char null_char
by (cases f; cases g, simp_all)
interpretation category comp
proof
fix f g h
show "comp g f ≠ null ⟹ seq g f"
using null_char arr_char seq_char by simp
show "domains f ≠ {} ⟷ codomains f ≠ {}"
using domains_char' codomains_char' by auto
show "seq h g ⟹ seq (comp h g) f ⟹ seq g f"
using seq_char arr_char
by (cases g; cases h; simp_all)
show "seq h (comp g f) ⟹ seq g f ⟹ seq h g"
using seq_char arr_char
by (cases f; cases g; simp_all)
show "seq g f ⟹ seq h g ⟹ seq (comp h g) f"
using seq_char arr_char
by (cases f; simp_all; cases g; simp_all; cases h; auto)
show "seq g f ⟹ seq h g ⟹ comp (comp h g) f = comp h (comp g f)"
using seq_char
by (cases f; simp_all; cases g; simp_all; cases h; auto)
qed
lemma is_category:
shows "category comp"
..
lemma dom_char:
shows "dom = Dom"
using dom_def domains_char domains_char' null_char by fastforce
lemma cod_char:
shows "cod = Cod"
using cod_def codomains_char codomains_char' null_char by fastforce
end
sublocale cospan_shape ⊆ category comp
using is_category by auto
locale cospan_diagram =
J: cospan_shape +
C: category C
for C :: "'c comp" (infixr "⋅" 55)
and f0 :: 'c
and f1 :: 'c +
assumes is_cospan: "C.cospan f0 f1"
begin
no_notation J.comp (infixr "⋅" 55)
notation J.comp (infixr "⋅⇩J" 55)
fun map
where "map J.AA = C.dom f0"
| "map J.BB = C.dom f1"
| "map J.TT = C.cod f0"
| "map J.AT = f0"
| "map J.BT = f1"
| "map _ = C.null"
end
sublocale cospan_diagram ⊆ diagram J.comp C map
proof
show "⋀f. ¬ J.arr f ⟹ map f = C.null"
using J.arr_char by simp
fix f
assume f: "J.arr f"
show "C.arr (map f)"
using f J.arr_char is_cospan by (cases f, simp_all)
show "C.dom (map f) = map (J.dom f)"
using f J.arr_char J.dom_char is_cospan by (cases f, simp_all)
show "C.cod (map f) = map (J.cod f)"
using f J.arr_char J.cod_char is_cospan by (cases f, simp_all)
next
fix f g
assume fg: "J.seq g f"
show "map (g ⋅⇩J f) = map g ⋅ map f"
using fg J.seq_char J.null_char J.not_arr_null is_cospan
apply (cases f; cases g, simp_all)
using C.comp_arr_dom C.comp_cod_arr by auto
qed
section "Category with Pullbacks"
text ‹
A \emph{pullback} in a category @{term C} is a limit of a cospan diagram in @{term C}.
›
context cospan_diagram
begin
definition mkCone
where "mkCone p0 p1 ≡ λj. if j = J.AA then p0
else if j = J.BB then p1
else if j = J.AT then f0 ⋅ p0
else if j = J.BT then f1 ⋅ p1
else if j = J.TT then f0 ⋅ p0
else C.null"
abbreviation is_rendered_commutative_by
where "is_rendered_commutative_by p0 p1 ≡ C.seq f0 p0 ∧ f0 ⋅ p0 = f1 ⋅ p1"
abbreviation has_as_pullback
where "has_as_pullback p0 p1 ≡ limit_cone (C.dom p0) (mkCone p0 p1)"
lemma cone_mkCone:
assumes "is_rendered_commutative_by p0 p1"
shows "cone (C.dom p0) (mkCone p0 p1)"
proof -
interpret E: constant_functor J.comp C ‹C.dom p0›
apply unfold_locales using assms by auto
show "cone (C.dom p0) (mkCone p0 p1)"
proof
fix f
show "¬ J.arr f ⟹ mkCone p0 p1 f = C.null"
using mkCone_def J.arr_char by simp
assume f: "J.arr f"
show "C.dom (mkCone p0 p1 f) = E.map (J.dom f)"
using assms f mkCone_def J.arr_char J.dom_char
apply (cases f, simp_all)
by (metis C.dom_comp)+
show "C.cod (mkCone p0 p1 f) = map (J.cod f)"
using assms f mkCone_def J.arr_char J.cod_char is_cospan
by (cases f, auto)
show "map f ⋅ mkCone p0 p1 (J.dom f) = mkCone p0 p1 f"
using assms f mkCone_def J.arr_char J.dom_char C.comp_ide_arr is_cospan
by (cases f, auto)
show "mkCone p0 p1 (J.cod f) ⋅ E.map f = mkCone p0 p1 f"
using assms f mkCone_def J.arr_char J.cod_char C.comp_arr_dom
apply (cases f, auto)
apply (metis C.dom_comp C.seqE)
by (metis C.dom_comp)+
qed
qed
lemma is_rendered_commutative_by_cone:
assumes "cone a χ"
shows "is_rendered_commutative_by (χ J.AA) (χ J.BB)"
proof -
interpret χ: cone J.comp C map a χ
using assms by auto
show ?thesis
proof
show "C.seq f0 (χ J.AA)"
by (metis C.seqI J.cod_char J.seq_char χ.preserves_cod χ.preserves_reflects_arr
J.seqE is_cospan J.Cod.simps(1) map.simps(1))
show "f0 ⋅ χ J.AA = f1 ⋅ χ J.BB"
by (metis J.cod_char J.dom_char χ.A.map_simp χ.naturality
J.Cod.simps(4-5) J.Dom.simps(4-5) J.comp.simps(2,5) J.seq_char map.simps(4-5))
qed
qed
lemma mkCone_cone:
assumes "cone a χ"
shows "mkCone (χ J.AA) (χ J.BB) = χ"
proof -
interpret χ: cone J.comp C map a χ
using assms by auto
have 1: "is_rendered_commutative_by (χ J.AA) (χ J.BB)"
using assms is_rendered_commutative_by_cone by blast
interpret mkCone_χ: cone J.comp C map ‹C.dom (χ J.AA)› ‹mkCone (χ J.AA) (χ J.BB)›
using assms cone_mkCone 1 by auto
show ?thesis
proof -
have "⋀j. j = J.AA ⟹ mkCone (χ J.AA) (χ J.BB) j = χ j"
using mkCone_def χ.is_extensional by simp
moreover have "⋀j. j = J.BB ⟹ mkCone (χ J.AA) (χ J.BB) j = χ j"
using mkCone_def χ.is_extensional by simp
moreover have "⋀j. j = J.TT ⟹ mkCone (χ J.AA) (χ J.BB) j = χ j"
using 1 mkCone_def χ.is_extensional χ.A.map_simp χ.preserves_comp_1
cospan_shape.seq_char χ.is_natural_2
apply simp
by (metis J.seqE J.comp.simps(5) map.simps(5))
ultimately have "⋀j. J.ide j ⟹ mkCone (χ J.AA) (χ J.BB) j = χ j"
using J.ide_char by auto
thus "mkCone (χ J.AA) (χ J.BB) = χ"
using mkCone_def NaturalTransformation.eqI [of J.comp C]
χ.natural_transformation_axioms mkCone_χ.natural_transformation_axioms
J.ide_char
by simp
qed
qed
end
locale pullback_cone =
J: cospan_shape +
C: category C +
D: cospan_diagram C f0 f1 +
limit_cone J.comp C D.map ‹C.dom p0› ‹D.mkCone p0 p1›
for C :: "'c comp" (infixr "⋅" 55)
and f0 :: 'c
and f1 :: 'c
and p0 :: 'c
and p1 :: 'c
begin
lemma renders_commutative:
shows "D.is_rendered_commutative_by p0 p1"
using D.mkCone_def D.cospan_diagram_axioms cone_axioms
cospan_diagram.is_rendered_commutative_by_cone
by fastforce
lemma is_universal':
assumes "D.is_rendered_commutative_by p0' p1'"
shows "∃!h. «h : C.dom p0' → C.dom p0» ∧ p0 ⋅ h = p0' ∧ p1 ⋅ h = p1'"
proof -
have "D.cone (C.dom p0') (D.mkCone p0' p1')"
using assms D.cone_mkCone by blast
hence 1: "∃!h. «h : C.dom p0' → C.dom p0» ∧
D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
using is_universal by simp
have 2: "⋀h. «h : C.dom p0' → C.dom p0» ⟹
D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1' ⟷
p0 ⋅ h = p0' ∧ p1 ⋅ h = p1'"
proof -
fix h
assume h: "«h : C.dom p0' → C.dom p0»"
show "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1' ⟷
p0 ⋅ h = p0' ∧ p1 ⋅ h = p1'"
proof
assume 3: "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
show "p0 ⋅ h = p0' ∧ p1 ⋅ h = p1'"
proof
show "p0 ⋅ h = p0'"
proof -
have "p0' = D.mkCone p0' p1' J.AA"
using D.mkCone_def J.arr_char by simp
also have "... = D.cones_map h (D.mkCone p0 p1) J.AA"
using 3 by simp
also have "... = p0 ⋅ h"
using h D.mkCone_def J.arr_char cone_χ by auto
finally show ?thesis by auto
qed
show "p1 ⋅ h = p1'"
proof -
have "p1' = D.mkCone p0' p1' J.BB"
using D.mkCone_def J.arr_char by simp
also have "... = D.cones_map h (D.mkCone p0 p1) J.BB"
using 3 by simp
also have "... = p1 ⋅ h"
using h D.mkCone_def J.arr_char cone_χ by auto
finally show ?thesis by auto
qed
qed
next
assume 4: "p0 ⋅ h = p0' ∧ p1 ⋅ h = p1'"
show "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
proof
fix j
have "¬ J.arr j ⟹ D.cones_map h (D.mkCone p0 p1) j = D.mkCone p0' p1' j"
using h cone_axioms D.mkCone_def J.arr_char by auto
moreover have "J.arr j ⟹
D.cones_map h (D.mkCone p0 p1) j = D.mkCone p0' p1' j"
using assms h 4 cone_χ D.mkCone_def J.arr_char renders_commutative
C.comp_assoc
by fastforce
ultimately show "D.cones_map h (D.mkCone p0 p1) j = D.mkCone p0' p1' j"
using J.arr_char J.Dom.cases by blast
qed
qed
qed
thus ?thesis using 1 by blast
qed
lemma induced_arrowI':
assumes "D.is_rendered_commutative_by p0' p1'"
shows "«induced_arrow (C.dom p0') (D.mkCone p0' p1') : C.dom p0' → C.dom p0»"
and "p0 ⋅ induced_arrow (C.dom p0') (D.mkCone p0' p1') = p0'"
and "p1 ⋅ induced_arrow (C.dom p1') (D.mkCone p0' p1') = p1'"
proof -
interpret A': constant_functor J.comp C ‹C.dom p0'›
using assms by (unfold_locales, auto)
have cone: "D.cone (C.dom p0') (D.mkCone p0' p1')"
using assms D.cone_mkCone [of p0' p1'] by blast
show 1: "p0 ⋅ induced_arrow (C.dom p0') (D.mkCone p0' p1') = p0'"
proof -
have "p0 ⋅ induced_arrow (C.dom p0') (D.mkCone p0' p1') =
D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
(D.mkCone p0 p1) J.AA"
using cone induced_arrowI(1) D.mkCone_def J.arr_char cone_χ by force
also have "... = p0'"
proof -
have "D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
(D.mkCone p0 p1) =
D.mkCone p0' p1'"
using cone induced_arrowI by blast
thus ?thesis
using J.arr_char D.mkCone_def by simp
qed
finally show ?thesis by auto
qed
show 2: "p1 ⋅ induced_arrow (C.dom p1') (D.mkCone p0' p1') = p1'"
proof -
have "p1 ⋅ induced_arrow (C.dom p1') (D.mkCone p0' p1') =
D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
(D.mkCone p0 p1) J.BB"
proof -
have "C.dom p0' = C.dom p1'"
using assms by (metis C.dom_comp)
thus ?thesis
using cone induced_arrowI(1) D.mkCone_def J.arr_char cone_χ by force
qed
also have "... = p1'"
proof -
have "D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
(D.mkCone p0 p1) =
D.mkCone p0' p1'"
using cone induced_arrowI by blast
thus ?thesis
using J.arr_char D.mkCone_def by simp
qed
finally show ?thesis by auto
qed
show "«induced_arrow (C.dom p0') (D.mkCone p0' p1') : C.dom p0' → C.dom p0»"
using 1 cone induced_arrowI by simp
qed
end
context category
begin
definition has_as_pullback
where "has_as_pullback f0 f1 p0 p1 ≡
cospan f0 f1 ∧ cospan_diagram.has_as_pullback C f0 f1 p0 p1"
definition has_pullbacks
where "has_pullbacks = (∀f0 f1. cospan f0 f1 ⟶ (∃p0 p1. has_as_pullback f0 f1 p0 p1))"
end
locale category_with_pullbacks =
category +
assumes has_pullbacks: has_pullbacks
section "Elementary Category with Pullbacks"
text ‹
An \emph{elementary category with pullbacks} is a category equipped with a specific
way of mapping each cospan to a span such that the resulting square commutes and
such that the span is universal for that property. It is useful to assume that the
functions, mapping a cospan to the two projections of the pullback, are extensional;
that is, they yield @{term null} when applied to arguments that do not form a cospan.
›
locale elementary_category_with_pullbacks =
category C
for C :: "'a comp" (infixr "⋅" 55)
and prj0 :: "'a ⇒ 'a ⇒ 'a" ("𝗉⇩0[_, _]")
and prj1 :: "'a ⇒ 'a ⇒ 'a" ("𝗉⇩1[_, _]") +
assumes prj0_ext: "¬ cospan f g ⟹ 𝗉⇩0[f, g] = null"
and prj1_ext: "¬ cospan f g ⟹ 𝗉⇩1[f, g] = null"
and pullback_commutes [intro]: "cospan f g ⟹ commutative_square f g 𝗉⇩1[f, g] 𝗉⇩0[f, g]"
and universal: "commutative_square f g h k ⟹ ∃!l. 𝗉⇩1[f, g] ⋅ l = h ∧ 𝗉⇩0[f, g] ⋅ l = k"
begin
lemma pullback_commutes':
assumes "cospan f g"
shows "f ⋅ 𝗉⇩1[f, g] = g ⋅ 𝗉⇩0[f, g]"
using assms commutative_square_def by blast
lemma prj0_in_hom':
assumes "cospan f g"
shows "«𝗉⇩0[f, g] : dom 𝗉⇩0[f, g] → dom g»"
using assms pullback_commutes
by (metis category.commutative_squareE category_axioms in_homI)
lemma prj1_in_hom':
assumes "cospan f g"
shows "«𝗉⇩1[f, g] : dom 𝗉⇩0[f, g] → dom f»"
using assms pullback_commutes
by (metis category.commutative_squareE category_axioms in_homI)
text ‹
The following gives us a notation for the common domain of the two projections
of a pullback.
›
definition pbdom (infix "↓↓" 51)
where "f ↓↓ g ≡ dom 𝗉⇩0[f, g]"
lemma pbdom_in_hom [intro]:
assumes "cospan f g"
shows "«f ↓↓ g : f ↓↓ g → f ↓↓ g»"
unfolding pbdom_def
using assms prj0_in_hom'
by (metis arr_dom_iff_arr arr_iff_in_hom cod_dom dom_dom in_homE)
lemma ide_pbdom [simp]:
assumes "cospan f g"
shows "ide (f ↓↓ g)"
using assms ide_in_hom by auto[1]
lemma prj0_in_hom [intro, simp]:
assumes "cospan f g" and "a = f ↓↓ g" and "b = dom g"
shows "«𝗉⇩0[f, g] : a → b»"
unfolding pbdom_def
using assms prj0_in_hom' by (simp add: pbdom_def)
lemma prj1_in_hom [intro, simp]:
assumes "cospan f g" and "a = f ↓↓ g" and "b = dom f"
shows "«𝗉⇩1[f, g] : a → b»"
unfolding pbdom_def
using assms prj1_in_hom' by (simp add: pbdom_def)
lemma prj0_simps [simp]:
assumes "cospan f g"
shows "arr 𝗉⇩0[f, g]" and "dom 𝗉⇩0[f, g] = f ↓↓ g" and "cod 𝗉⇩0[f, g] = dom g"
using assms prj0_in_hom by (blast, blast, blast)
lemma prj0_simps_arr [iff]:
shows "arr 𝗉⇩0[f, g] ⟷ cospan f g"
proof
show "cospan f g ⟹ arr 𝗉⇩0[f, g]"
using prj0_in_hom by auto
show "arr 𝗉⇩0[f, g] ⟹ cospan f g"
using prj0_ext not_arr_null by metis
qed
lemma prj1_simps [simp]:
assumes "cospan f g"
shows "arr 𝗉⇩1[f, g]" and "dom 𝗉⇩1[f, g] = f ↓↓ g" and "cod 𝗉⇩1[f, g] = dom f"
using assms prj1_in_hom by (blast, blast, blast)
lemma prj1_simps_arr [iff]:
shows "arr 𝗉⇩1[f, g] ⟷ cospan f g"
proof
show "cospan f g ⟹ arr 𝗉⇩1[f, g]"
using prj1_in_hom by auto
show "arr 𝗉⇩1[f, g] ⟹ cospan f g"
using prj1_ext not_arr_null by metis
qed
lemma span_prj:
assumes "cospan f g"
shows "span 𝗉⇩0[f, g] 𝗉⇩1[f, g]"
using assms by simp
text ‹
We introduce a notation for tupling, which produces the induced arrow into a pullback.
In our notation, the ``$0$-side'', which we regard as the input, occurs on the right,
and the ``$1$-side'', which we regard as the output, occurs on the left.
›
definition tuple ("⟨_ ⟦_, _⟧ _⟩")
where "⟨h ⟦f, g⟧ k⟩ ≡ if commutative_square f g h k then
THE l. 𝗉⇩0[f, g] ⋅ l = k ∧ 𝗉⇩1[f, g] ⋅ l = h
else null"
lemma tuple_in_hom [intro]:
assumes "commutative_square f g h k"
shows "«⟨h ⟦f, g⟧ k⟩ : dom h → f ↓↓ g»"
proof
have 1: "𝗉⇩0[f, g] ⋅ ⟨h ⟦f, g⟧ k⟩ = k ∧ 𝗉⇩1[f, g] ⋅ ⟨h ⟦f, g⟧ k⟩ = h"
unfolding tuple_def
using assms universal theI [of "λl. 𝗉⇩0[f, g] ⋅ l = k ∧ 𝗉⇩1[f, g] ⋅ l = h"]
apply simp
by meson
show "arr ⟨h ⟦f, g⟧ k⟩"
using assms 1
apply (elim commutative_squareE)
by (metis (no_types, lifting) seqE)
show "dom ⟨h ⟦f, g⟧ k⟩ = dom h"
using assms 1
apply (elim commutative_squareE)
by (metis (no_types, lifting) dom_comp)
show "cod ⟨h ⟦f, g⟧ k⟩ = f ↓↓ g"
unfolding pbdom_def
using assms 1
apply (elim commutative_squareE)
by (metis seqE)
qed
lemma tuple_is_extensional:
assumes "¬ commutative_square f g h k"
shows "⟨h ⟦f, g⟧ k⟩ = null"
unfolding tuple_def
using assms by simp
lemma tuple_simps [simp]:
assumes "commutative_square f g h k"
shows "arr ⟨h ⟦f, g⟧ k⟩" and "dom ⟨h ⟦f, g⟧ k⟩ = dom h" and "cod ⟨h ⟦f, g⟧ k⟩ = f ↓↓ g"
using assms tuple_in_hom apply blast
using assms tuple_in_hom apply blast
using assms tuple_in_hom by blast
lemma prj_tuple [simp]:
assumes "commutative_square f g h k"
shows "𝗉⇩0[f, g] ⋅ ⟨h ⟦f, g⟧ k⟩ = k" and "𝗉⇩1[f, g] ⋅ ⟨h ⟦f, g⟧ k⟩ = h"
proof -
have 1: "𝗉⇩0[f, g] ⋅ ⟨h ⟦f, g⟧ k⟩ = k ∧ 𝗉⇩1[f, g] ⋅ ⟨h ⟦f, g⟧ k⟩ = h"
unfolding tuple_def
using assms universal theI [of "λl. 𝗉⇩0[f, g] ⋅ l = k ∧ 𝗉⇩1[f, g] ⋅ l = h"]
apply simp
by meson
show "𝗉⇩0[f, g] ⋅ ⟨h ⟦f, g⟧ k⟩ = k" using 1 by simp
show "𝗉⇩1[f, g] ⋅ ⟨h ⟦f, g⟧ k⟩ = h" using 1 by simp
qed
lemma tuple_prj:
assumes "cospan f g" and "seq 𝗉⇩1[f, g] h"
shows "⟨𝗉⇩1[f, g] ⋅ h ⟦f, g⟧ 𝗉⇩0[f, g] ⋅ h⟩ = h"
proof -
have 1: "commutative_square f g (𝗉⇩1[f, g] ⋅ h) (𝗉⇩0[f, g] ⋅ h)"
using assms pullback_commutes
by (simp add: commutative_square_comp_arr)
have "𝗉⇩0[f, g] ⋅ ⟨𝗉⇩1[f, g] ⋅ h ⟦f, g⟧ 𝗉⇩0[f, g] ⋅ h⟩ = 𝗉⇩0[f, g] ⋅ h"
using assms 1 by simp
moreover have "𝗉⇩1[f, g] ⋅ ⟨𝗉⇩1[f, g] ⋅ h ⟦f, g⟧ 𝗉⇩0[f, g] ⋅ h⟩ = 𝗉⇩1[f, g] ⋅ h"
using assms 1 by simp
ultimately show ?thesis
unfolding tuple_def
using assms 1 universal [of f g "𝗉⇩1[f, g] ⋅ h" "𝗉⇩0[f, g] ⋅ h"]
theI_unique [of "λl. 𝗉⇩0[f, g] ⋅ l = 𝗉⇩0[f, g] ⋅ h ∧ 𝗉⇩1[f, g] ⋅ l = 𝗉⇩1[f, g] ⋅ h" h]
by auto
qed
lemma tuple_prj_spc [simp]:
assumes "cospan f g"
shows "⟨𝗉⇩1[f, g] ⟦f, g⟧ 𝗉⇩0[f, g]⟩ = f ↓↓ g"
proof -
have "⟨𝗉⇩1[f, g] ⟦f, g⟧ 𝗉⇩0[f, g]⟩ = ⟨𝗉⇩1[f, g] ⋅ (f ↓↓ g) ⟦f, g⟧ 𝗉⇩0[f, g] ⋅ (f ↓↓ g)⟩"
using assms comp_arr_dom by simp
thus ?thesis
using assms tuple_prj by simp
qed
lemma prj_joint_monic:
assumes "cospan f g" and "seq 𝗉⇩1[f, g] h" and "seq 𝗉⇩1[f, g] h'"
and "𝗉⇩0[f, g] ⋅ h = 𝗉⇩0[f, g] ⋅ h'" and "𝗉⇩1[f, g] ⋅ h = 𝗉⇩1[f, g] ⋅ h'"
shows "h = h'"
proof -
have "h = ⟨𝗉⇩1[f, g] ⋅ h ⟦f, g⟧ 𝗉⇩0[f, g] ⋅ h⟩"
using assms tuple_prj [of f g h] by simp
also have "... = ⟨𝗉⇩1[f, g] ⋅ h' ⟦f, g⟧ 𝗉⇩0[f, g] ⋅ h'⟩"
using assms by simp
also have "... = h'"
using assms tuple_prj [of f g h'] by simp
finally show ?thesis by blast
qed
text ‹
The pullback of an identity along an arbitrary arrow is an isomorphism.
›
lemma iso_pullback_ide:
assumes "cospan μ ν" and "ide μ"
shows "iso 𝗉⇩0[μ, ν]"
proof -
have "inverse_arrows 𝗉⇩0[μ, ν] ⟨ν ⟦μ, ν⟧ dom ν⟩"
proof
show 1: "ide (𝗉⇩0[μ, ν] ⋅ ⟨ν ⟦μ, ν⟧ dom ν⟩)"
using assms comp_arr_dom comp_cod_arr prj_tuple(1) by simp
show "ide (⟨ν ⟦μ, ν⟧ dom ν⟩ ⋅ 𝗉⇩0[μ, ν])"
proof -
have "⟨ν ⟦μ, ν⟧ dom ν⟩ ⋅ 𝗉⇩0[μ, ν] = (μ ↓↓ ν)"
proof -
have "𝗉⇩0[μ, ν] ⋅ ⟨ν ⟦μ, ν⟧ dom ν⟩ ⋅ 𝗉⇩0[μ, ν] = 𝗉⇩0[μ, ν] ⋅ (μ ↓↓ ν)"
proof -
have "𝗉⇩0[μ, ν] ⋅ ⟨ν ⟦μ, ν⟧ dom ν⟩ ⋅ 𝗉⇩0[μ, ν] = (𝗉⇩0[μ, ν] ⋅ ⟨ν ⟦μ, ν⟧ dom ν⟩) ⋅ 𝗉⇩0[μ, ν]"
using assms 1 comp_reduce by blast
also have "... = 𝗉⇩0[μ, ν] ⋅ (μ ↓↓ ν)"
using assms prj_tuple(1) pullback_commutes comp_arr_dom comp_cod_arr by simp
finally show ?thesis by blast
qed
moreover have "𝗉⇩1[μ, ν] ⋅ ⟨ν ⟦μ, ν⟧ dom ν⟩ ⋅ 𝗉⇩0[μ, ν] = 𝗉⇩1[μ, ν] ⋅ (μ ↓↓ ν)"
proof -
have "𝗉⇩1[μ, ν] ⋅ ⟨ν ⟦μ, ν⟧ dom ν⟩ ⋅ 𝗉⇩0[μ, ν] = (𝗉⇩1[μ, ν] ⋅ ⟨ν ⟦μ, ν⟧ dom ν⟩) ⋅ 𝗉⇩0[μ, ν]"
using assms(2) comp_assoc by simp
also have "... = ν ⋅ 𝗉⇩0[μ, ν]"
using assms comp_arr_dom comp_cod_arr prj_tuple(2) by fastforce
also have "... = μ ⋅ 𝗉⇩1[μ, ν]"
using assms pullback_commutes commutative_square_def by simp
also have "... = 𝗉⇩1[μ, ν] ⋅ (μ ↓↓ ν)"
using assms comp_arr_dom comp_cod_arr pullback_commutes commutative_square_def
by simp
finally show ?thesis by simp
qed
ultimately show ?thesis
using assms prj0_in_hom prj1_in_hom comp_arr_dom prj1_simps(1-2) prj_joint_monic
by metis
qed
thus ?thesis
using assms by auto
qed
qed
thus ?thesis by auto
qed
lemma comp_tuple_arr:
assumes "commutative_square f g h k" and "seq h l"
shows "⟨h ⟦f, g⟧ k⟩ ⋅ l = ⟨h ⋅ l ⟦f, g⟧ k ⋅ l⟩"
proof -
have "𝗉⇩0[f, g] ⋅ ⟨h ⟦f, g⟧ k⟩ ⋅ l = 𝗉⇩0[f, g] ⋅ ⟨h ⋅ l ⟦f, g⟧ k ⋅ l⟩"
proof -
have "𝗉⇩0[f, g] ⋅ ⟨h ⟦f, g⟧ k⟩ ⋅ l = (𝗉⇩0[f, g] ⋅ ⟨h ⟦f, g⟧ k⟩) ⋅ l"
using comp_assoc by simp
also have "... = 𝗉⇩0[f, g] ⋅ ⟨h ⋅ l ⟦f, g⟧ k ⋅ l⟩"
using assms commutative_square_comp_arr by auto
finally show ?thesis by blast
qed
moreover have "𝗉⇩1[f, g] ⋅ ⟨h ⟦f, g⟧ k⟩ ⋅ l = 𝗉⇩1[f, g] ⋅ ⟨h ⋅ l ⟦f, g⟧ k ⋅ l⟩"
proof -
have "𝗉⇩1[f, g] ⋅ ⟨h ⟦f, g⟧ k⟩ ⋅ l = (𝗉⇩1[f, g] ⋅ ⟨h ⟦f, g⟧ k⟩) ⋅ l"
using comp_assoc by simp
also have "... = 𝗉⇩1[f, g] ⋅ ⟨h ⋅ l ⟦f, g⟧ k ⋅ l⟩"
using assms commutative_square_comp_arr by auto
finally show ?thesis by blast
qed
moreover have "seq 𝗉⇩1[f, g] (⟨h ⟦f, g⟧ k⟩ ⋅ l)"
using assms tuple_in_hom prj1_in_hom by fastforce
ultimately show ?thesis
using assms prj_joint_monic [of f g "⟨h ⟦f, g⟧ k⟩ ⋅ l" "⟨h ⋅ l ⟦f, g⟧ k ⋅ l⟩"]
by auto
qed
lemma pullback_arr_cod:
assumes "arr f"
shows "inverse_arrows 𝗉⇩1[f, cod f] ⟨dom f ⟦f, cod f⟧ f⟩"
and "inverse_arrows 𝗉⇩0[cod f, f] ⟨f ⟦cod f, f⟧ dom f⟩"
proof -
show "inverse_arrows 𝗉⇩1[f, cod f] ⟨dom f ⟦f, cod f⟧ f⟩"
proof
show "ide (⟨dom f ⟦f, cod f⟧ f⟩ ⋅ 𝗉⇩1[f, cod f])"
proof -
have "⟨dom f ⟦f, cod f⟧ f⟩ ⋅ 𝗉⇩1[f, cod f] = f ↓↓ cod f"
proof -
have "𝗉⇩0[f, cod f] ⋅ ⟨dom f ⟦f, cod f⟧ f⟩ ⋅ 𝗉⇩1[f, cod f] = 𝗉⇩0[f, cod f] ⋅ (f ↓↓ cod f)"
proof -
have "𝗉⇩0[f, cod f] ⋅ ⟨dom f ⟦f, cod f⟧ f⟩ ⋅ 𝗉⇩1[f, cod f] =
(𝗉⇩0[f, cod f] ⋅ ⟨dom f ⟦f, cod f⟧ f⟩) ⋅ 𝗉⇩1[f, cod f]"
using comp_assoc by simp
also have "... = 𝗉⇩0[f, cod f] ⋅ (f ↓↓ cod f)"
using assms pullback_commutes [of f "cod f"] comp_arr_dom comp_cod_arr
by auto
finally show ?thesis by blast
qed
moreover
have "𝗉⇩1[f, cod f] ⋅ ⟨dom f ⟦f, cod f⟧ f⟩ ⋅ 𝗉⇩1[f, cod f] = 𝗉⇩1[f, cod f] ⋅ (f ↓↓ cod f)"
proof -
have "𝗉⇩1[f, cod f] ⋅ ⟨dom f ⟦f, cod f⟧ f⟩ ⋅ 𝗉⇩1[f, cod f] =
(𝗉⇩1[f, cod f] ⋅ ⟨dom f ⟦f, cod f⟧ f⟩) ⋅ 𝗉⇩1[f, cod f]"
using assms comp_assoc by presburger
also have "... = 𝗉⇩1[f, cod f] ⋅ (f ↓↓ cod f)"
using assms comp_arr_dom comp_cod_arr by simp
finally show ?thesis by blast
qed
ultimately show ?thesis
using assms
prj_joint_monic
[of f "cod f" "⟨dom f ⟦f, cod f⟧ f⟩ ⋅ 𝗉⇩1[f, cod f]" "f ↓↓ cod f"]
by simp
qed
thus ?thesis
using assms arr_cod cod_cod prj1_simps_arr by simp
qed
show "ide (𝗉⇩1[f, cod f] ⋅ ⟨dom f ⟦f, cod f⟧ f⟩)"
using assms comp_arr_dom comp_cod_arr by fastforce
qed
show "inverse_arrows 𝗉⇩0[cod f, f] ⟨f ⟦cod f, f⟧ dom f⟩"
proof
show "ide (𝗉⇩0[cod f, f] ⋅ ⟨f ⟦cod f, f⟧ dom f⟩)"
using assms comp_arr_dom comp_cod_arr by simp
show "ide (⟨f ⟦cod f, f⟧ dom f⟩ ⋅ 𝗉⇩0[cod f, f])"
proof -
have "⟨f ⟦cod f, f⟧ dom f⟩ ⋅ 𝗉⇩0[cod f, f] = cod f ↓↓ f"
proof -
have "𝗉⇩0[cod f, f] ⋅ ⟨f ⟦cod f, f⟧ dom f⟩ ⋅ 𝗉⇩0[cod f, f] = 𝗉⇩0[cod f, f] ⋅ (cod f ↓↓ f)"
proof -
have "𝗉⇩0[cod f, f] ⋅ ⟨f ⟦cod f, f⟧ dom f⟩ ⋅ 𝗉⇩0[cod f, f] =
(𝗉⇩0[cod f, f] ⋅ ⟨f ⟦cod f, f⟧ dom f⟩) ⋅ 𝗉⇩0[cod f, f]"
using comp_assoc by simp
also have "... = dom f ⋅ 𝗉⇩0[cod f, f]"
using assms comp_arr_dom comp_cod_arr by simp
also have "... = 𝗉⇩0[cod f, f] ⋅ (cod f ↓↓ f)"
using assms comp_arr_dom comp_cod_arr by simp
finally show ?thesis
using prj0_in_hom by blast
qed
moreover
have "𝗉⇩1[cod f, f] ⋅ ⟨f ⟦cod f, f⟧ dom f⟩ ⋅ 𝗉⇩0[cod f, f] = 𝗉⇩1[cod f, f] ⋅ (cod f ↓↓ f)"
proof -
have "𝗉⇩1[cod f, f] ⋅ ⟨f ⟦cod f, f⟧ dom f⟩ ⋅ 𝗉⇩0[cod f, f] =
(𝗉⇩1[cod f, f] ⋅ ⟨f ⟦cod f, f⟧ dom f⟩) ⋅ 𝗉⇩0[cod f, f]"
using comp_assoc by simp
also have "... = 𝗉⇩1[cod f, f] ⋅ (cod f ↓↓ f)"
using assms pullback_commutes [of "cod f" f] comp_arr_dom comp_cod_arr
by auto
finally show ?thesis by blast
qed
ultimately show ?thesis
using assms prj_joint_monic [of "cod f" f "⟨f ⟦cod f, f⟧ dom f⟩ ⋅ 𝗉⇩0[cod f, f]"]
by simp
qed
thus ?thesis using assms by simp
qed
qed
qed
text ‹
The pullback of a monomorphism along itself is automatically symmetric: the left
and right projections are equal.
›
lemma pullback_mono_self:
assumes "mono f"
shows "𝗉⇩0[f, f] = 𝗉⇩1[f, f]"
proof -
have "f ⋅ 𝗉⇩0[f, f] = f ⋅ 𝗉⇩1[f, f]"
using assms pullback_commutes [of f f]
by (metis commutative_squareE mono_implies_arr)
thus ?thesis
using assms monoE [of f "𝗉⇩1[f, f]" "𝗉⇩0[f, f]"]
by (metis mono_implies_arr prj0_simps(1,3) seqI)
qed
lemma pullback_iso_self:
assumes "iso f"
shows "𝗉⇩0[f, f] = 𝗉⇩1[f, f]"
using assms pullback_mono_self iso_is_section section_is_mono by simp
lemma pullback_ide_self [simp]:
assumes "ide a"
shows "𝗉⇩0[a, a] = 𝗉⇩1[a, a]"
using assms pullback_iso_self ide_is_iso by blast
end
section "Agreement between the Definitions"
text ‹
It is very easy to write locale assumptions that have unintended consequences
or that are even inconsistent. So, to keep ourselves honest, we don't just accept the
definition of ``elementary category with pullbacks'', but in fact we formally establish
the sense in which it agrees with our standard definition of ``category with pullbacks'',
which is given in terms of limit cones.
This is extra work, but it ensures that we didn't make a mistake.
›
context category_with_pullbacks
begin
definition prj1
where "prj1 f g ≡ if cospan f g then
fst (SOME x. cospan_diagram.has_as_pullback C f g (fst x) (snd x))
else null"
definition prj0
where "prj0 f g ≡ if cospan f g then
snd (SOME x. cospan_diagram.has_as_pullback C f g (fst x) (snd x))
else null"
lemma prj_yields_pullback:
assumes "cospan f g"
shows "cospan_diagram.has_as_pullback C f g (prj1 f g) (prj0 f g)"
proof -
have "∃x. cospan_diagram.has_as_pullback C f g (fst x) (snd x)"
using assms has_pullbacks has_pullbacks_def has_as_pullback_def by simp
thus ?thesis
using assms has_pullbacks has_pullbacks_def prj0_def prj1_def
someI_ex [of "λx. cospan_diagram.has_as_pullback C f g (fst x) (snd x)"]
by simp
qed
interpretation elementary_category_with_pullbacks C prj0 prj1
proof
show "⋀f g. ¬ cospan f g ⟹ prj0 f g = null"
using prj0_def by auto
show "⋀f g. ¬ cospan f g ⟹ prj1 f g = null"
using prj1_def by auto
show "⋀f g. cospan f g ⟹ commutative_square f g (prj1 f g) (prj0 f g)"
proof
fix f g
assume fg: "cospan f g"
show "cospan f g" by fact
interpret J: cospan_shape .
interpret D: cospan_diagram C f g
using fg by (unfold_locales, auto)
let ?χ = "D.mkCone (prj1 f g) (prj0 f g)"
interpret χ: limit_cone J.comp C D.map ‹dom (prj1 f g)› ?χ
using fg prj_yields_pullback by auto
have 1: "prj1 f g = ?χ J.AA ∧ prj0 f g = ?χ J.BB"
using D.mkCone_def by simp
show "span (prj1 f g) (prj0 f g)"
proof -
have "arr (prj1 f g) ∧ arr (prj0 f g)"
using 1 J.arr_char J.seq_char
by (metis J.seqE χ.preserves_reflects_arr)
moreover have "dom (prj1 f g) = dom (prj0 f g)"
using 1 D.is_rendered_commutative_by_cone χ.cone_axioms J.seq_char
by (metis J.cod_eqI J.seqE χ.A.map_simp χ.preserves_dom J.ide_char)
ultimately show ?thesis by simp
qed
show "dom f = cod (prj1 f g)"
using 1 fg χ.preserves_cod [of J.BB] J.cod_char D.mkCone_def
by (metis D.map.simps(1) D.preserves_cod J.seqE χ.preserves_cod cod_dom J.seq_char)
show "f ⋅ prj1 f g = g ⋅ prj0 f g"
using 1 fg D.is_rendered_commutative_by_cone χ.cone_axioms by force
qed
show "⋀f g h k. commutative_square f g h k ⟹ ∃!l. prj1 f g ⋅ l = h ∧ prj0 f g ⋅ l = k"
proof -
fix f g h k
assume fghk: "commutative_square f g h k"
interpret J: cospan_shape .
interpret D: cospan_diagram C f g
using fghk by (unfold_locales, auto)
let ?χ = "D.mkCone (prj1 f g) (prj0 f g)"
interpret χ: limit_cone J.comp C D.map ‹dom (prj1 f g)› ?χ
using fghk prj_yields_pullback by auto
interpret χ: pullback_cone C f g ‹prj1 f g› ‹prj0 f g› ..
have 1: "prj1 f g = ?χ J.AA ∧ prj0 f g = ?χ J.BB"
using D.mkCone_def by simp
show "∃!l. prj1 f g ⋅ l = h ∧ prj0 f g ⋅ l = k"
proof
let ?l = "SOME l. prj1 f g ⋅ l = h ∧ prj0 f g ⋅ l = k"
show "prj1 f g ⋅ ?l = h ∧ prj0 f g ⋅ ?l = k"
using fghk χ.is_universal' χ.renders_commutative
someI_ex [of "λl. prj1 f g ⋅ l = h ∧ prj0 f g ⋅ l = k"]
by blast
thus "⋀l. prj1 f g ⋅ l = h ∧ prj0 f g ⋅ l = k ⟹ l = ?l"
using fghk χ.is_universal' χ.renders_commutative limit_cone_def
by (metis (no_types, lifting) in_homI seqE commutative_squareE dom_comp seqI)
qed
qed
qed
proposition extends_to_elementary_category_with_pullbacks:
shows "elementary_category_with_pullbacks C prj0 prj1"
..
end
context elementary_category_with_pullbacks
begin
interpretation category_with_pullbacks C
proof
show "has_pullbacks"
proof (unfold has_pullbacks_def)
have "⋀f g. cospan f g ⟹ ∃p0 p1. has_as_pullback f g p0 p1"
proof -
fix f g
assume fg: "cospan f g"
interpret J: cospan_shape .
interpret D: cospan_diagram C f g
using fg by (unfold_locales, auto)
let ?χ = "D.mkCone 𝗉⇩1[f, g] 𝗉⇩0[f, g]"
interpret χ: cone J.comp C D.map ‹dom 𝗉⇩1[f, g]› ?χ
proof -
have "D.is_rendered_commutative_by 𝗉⇩1[f, g] 𝗉⇩0[f, g]"
using fg pullback_commutes' by simp
thus "cone J.comp C D.map (dom 𝗉⇩1[f, g]) ?χ"
using D.cone_mkCone by auto
qed
interpret χ: limit_cone J.comp C D.map ‹dom 𝗉⇩1[f, g]› ?χ
proof
fix a' χ'
assume χ': "D.cone a' χ'"
interpret χ': cone J.comp C D.map a' χ'
using χ' by simp
have 1: "commutative_square f g (χ' J.AA) (χ' J.BB)"
using fg J.ide_char J.cod_char D.is_rendered_commutative_by_cone χ'.cone_axioms
by auto
show "∃!h. «h : a' → dom 𝗉⇩1[f, g]» ∧
D.cones_map h (D.mkCone 𝗉⇩1[f, g] 𝗉⇩0[f, g]) = χ'"
proof
let ?h = "⟨χ' J.AA ⟦f, g⟧ χ' J.BB⟩"
show h': "«?h : a' → dom 𝗉⇩1[f, g]» ∧
D.cones_map ?h (D.mkCone 𝗉⇩1[f, g] 𝗉⇩0[f, g]) = χ'"
proof
show h: "«?h : a' → dom 𝗉⇩1[f, g]»"
using fg 1 by fastforce
show "D.cones_map ?h (D.mkCone 𝗉⇩1[f, g] 𝗉⇩0[f, g]) = χ'"
proof -
have "D.mkCone 𝗉⇩1[f, g] 𝗉⇩0[f, g] ∈ D.cones (cod ⟨χ' J.AA ⟦f, g⟧ χ' J.BB⟩)"
using fg h D.cone_mkCone D.is_rendered_commutative_by_cone
χ.cone_axioms
by auto
hence 2: "D.cones_map ?h (D.mkCone 𝗉⇩1[f, g] 𝗉⇩0[f, g]) ∈ D.cones a'"
using fg h D.cones_map_mapsto by blast
interpret χ'h: cone J.comp C D.map a'
‹D.cones_map ?h (D.mkCone 𝗉⇩1[f, g] 𝗉⇩0[f, g])›
using 2 by simp
show ?thesis
proof -
have "⋀j. J.ide j ⟹ D.cones_map ?h (D.mkCone 𝗉⇩1[f, g] 𝗉⇩0[f, g]) j = χ' j"
proof -
fix j
show "J.ide j ⟹ D.cones_map ?h (D.mkCone 𝗉⇩1[f, g] 𝗉⇩0[f, g]) j = χ' j"
using fg h 1 J.ide_char D.mkCone_def χ.cone_axioms
apply (cases j, simp_all)
by (metis D.map.simps(4) J.dom_eqI χ'.is_natural_1 χ'.naturality
J.seqE χ'.A.map_simp J.comp.simps(3,7) J.seq_char
prj_tuple(2) comp_assoc)
qed
thus ?thesis
using NaturalTransformation.eqI
χ'.natural_transformation_axioms χ'h.natural_transformation_axioms
by blast
qed
qed
qed
show "⋀h. «h : a' → dom 𝗉⇩1[f, g]» ∧
D.cones_map h (D.mkCone 𝗉⇩1[f, g] 𝗉⇩0[f, g]) = χ' ⟹
h = ?h"
proof -
fix h
assume 2: "«h : a' → dom 𝗉⇩1[f, g]» ∧
D.cones_map h (D.mkCone 𝗉⇩1[f, g] 𝗉⇩0[f, g]) = χ'"
show "h = ?h"
proof -
have "𝗉⇩0[f, g] ⋅ h = 𝗉⇩0[f, g] ⋅ ?h ∧ 𝗉⇩1[f, g] ⋅ h = 𝗉⇩1[f, g] ⋅ ?h"
using 1 2 fg J.arr_char χ.cone_axioms D.mkCone_def by auto
thus ?thesis
using fg 2 h' prj_joint_monic by blast
qed
qed
qed
qed
show "∃p0 p1. has_as_pullback f g p0 p1"
using fg has_as_pullback_def χ.limit_cone_axioms by blast
qed
thus "∀f g. cospan f g ⟶ (∃p0 p1. has_as_pullback f g p0 p1)"
by simp
qed
qed
proposition is_category_with_pullbacks:
shows "category_with_pullbacks C"
..
end
sublocale elementary_category_with_pullbacks ⊆ category_with_pullbacks
using is_category_with_pullbacks by auto
end
Theory CategoryWithFiniteLimits
chapter "Category with Finite Limits"
theory CategoryWithFiniteLimits
imports CartesianCategory CategoryWithPullbacks
begin
text‹
In this chapter we define ``category with finite limits'' and show that such
categories coincide with those having pullbacks and a terminal object.
Since we can't quantify over types in HOL, the best we can do at defining the notion
``category with finite limits'' is to state it for a fixed choice of type (e.g.~@{typ nat})
for the arrows of the ``diagram shape''. However, we then have to go to some
trouble to show the existence of finite limits for diagram shapes at other types.
›
locale category_with_finite_limits =
category +
assumes has_finite_limits:
"⟦ category (J :: nat comp); finite (Collect (partial_magma.arr J)) ⟧
⟹ has_limits_of_shape J"
begin
text‹
We show that a category with finite limits has pullbacks and a terminal object
and is therefore also a cartesian category.
›
interpretation category_with_pullbacks C
proof -
interpret J: cospan_shape
by unfold_locales
have 1: "finite (Collect J.arr)"
proof -
have "Collect J.arr = {J.AA, J.BB, J.TT, J.AT, J.BT}"
using J.arr_char cospan_shape.Dom.cases by auto
thus ?thesis by simp
qed
obtain J' :: "nat comp" where J': "isomorphic_categories J' J.comp"
using 1 J.finite_imp_ex_iso_nat_comp by blast
interpret J'J: isomorphic_categories J' J.comp
using J' by simp
obtain φ ψ where φψ: "inverse_functors J.comp J' φ ψ"
using J'J.iso inverse_functors_sym by blast
interpret φψ: inverse_functors J.comp J' φ ψ
using φψ by simp
interpret ψ: invertible_functor J.comp J' ψ
using φψ.inverse_functors_axioms
by unfold_locales auto
show "category_with_pullbacks C"
proof
show "has_pullbacks"
proof (unfold has_pullbacks_def has_as_pullback_def, intro allI impI)
fix f0 f1
assume cospan: "cospan f0 f1"
interpret D: cospan_diagram C f0 f1
using cospan
by (simp add: category_axioms cospan_diagram_axioms_def cospan_diagram_def)
have 2: "has_limits_of_shape J.comp"
using 1 bij_betw_finite J'J.A.category_axioms has_finite_limits ψ.bij_betw_arr_sets
has_limits_preserved_by_isomorphism J'J.isomorphic_categories_axioms
by blast
obtain a χ where χ: "limit_cone J.comp C D.map a χ"
using 2 D.diagram_axioms has_limits_of_shape_def by blast
interpret χ: limit_cone J.comp C D.map a χ
using χ by simp
have "D.map = cospan_diagram.map C f0 f1" by simp
moreover have "a = dom (χ J.AA)"
using J.arr_char χ.component_in_hom by force
moreover have "χ = cospan_diagram.mkCone (⋅) f0 f1 (χ J.AA) (χ J.BB)"
using D.mkCone_cone χ.cone_axioms by auto
ultimately have "limit_cone (⋅⇩J) (⋅)
(cospan_diagram.map (⋅) f0 f1) (dom (χ J.AA))
(cospan_diagram.mkCone (⋅) f0 f1 (χ J.AA) (χ J.BB))"
using χ.limit_cone_axioms by simp
thus "∃p0 p1. cospan f0 f1 ∧
limit_cone (⋅⇩J) (⋅)
(cospan_diagram.map (⋅) f0 f1) (dom p0)
(cospan_diagram.mkCone (⋅) f0 f1 p0 p1)"
using cospan by auto
qed
qed
qed
lemma is_category_with_pullbacks:
shows "category_with_pullbacks C"
..
sublocale category_with_pullbacks C ..
interpretation category_with_terminal_object C
proof
show "∃a. terminal a"
proof -
interpret J: discrete_category ‹{} :: nat set› 0
by unfold_locales simp
have 1: "has_limits_of_shape J.comp"
using has_finite_limits
by (metis Collect_empty_eq J.arr_char J.is_category empty_iff finite.emptyI)
interpret D: diagram J.comp C ‹λ_. null›
by unfold_locales auto
obtain t τ where τ: "D.limit_cone t τ"
using 1 D.diagram_axioms has_limits_of_shape_def by blast
interpret τ: limit_cone J.comp C ‹λ_. null› t τ
using τ by simp
have "terminal t"
proof
show "ide t"
using τ.ide_apex by simp
fix a
assume a: "ide a"
show "∃!f. «f : a → t»"
proof -
interpret a: constant_functor J.comp C a
using a by unfold_locales
interpret χ: cone J.comp C ‹λ_.null› a ‹λ_.null›
apply unfold_locales
apply simp
using dom_null cod_null comp_null
by blast+
have "∃!f. «f : a → t» ∧ D.cones_map f τ = (λ_. null)"
using τ.induced_arrowI [of "λ_.null" a] χ.cone_axioms
τ.is_universal [of a "λ_. null"]
by simp
moreover have "⋀f. «f : a → t» ⟹ D.cones_map f τ = (λ_. null)"
using τ.cone_axioms by auto
ultimately show ?thesis by auto
qed
qed
thus ?thesis by blast
qed
qed
lemma is_category_with_terminal_object:
shows "category_with_terminal_object C"
..
sublocale category_with_terminal_object C ..
sublocale category_with_finite_products
using has_finite_limits has_finite_products_if_has_finite_limits
has_limits_of_shape_def diagram_def
by unfold_locales blast
sublocale cartesian_category ..
end
locale category_with_pullbacks_and_terminal =
category_with_pullbacks +
category_with_terminal_object
sublocale category_with_finite_limits ⊆ category_with_pullbacks_and_terminal ..
text‹
Conversely, we show that a category with pullbacks and a terminal object also
has finite products and equalizers, and therefore has finite limits.
›
context category_with_pullbacks_and_terminal
begin
interpretation ECP: elementary_category_with_pullbacks C prj0 prj1
using extends_to_elementary_category_with_pullbacks by simp
abbreviation prj0'
where "prj0' a b ≡ (if ide a ∧ ide b then prj0 (trm a) (trm b) else null)"
abbreviation prj1'
where "prj1' a b ≡ (if ide a ∧ ide b then prj1 (trm a) (trm b) else null)"
interpretation ECC: elementary_cartesian_category C prj0' prj1' 𝟭 trm
using trm_naturality ECP.universal
by unfold_locales auto
interpretation category_with_equalizers C
proof (unfold_locales, unfold has_equalizers_def, intro allI impI)
fix f0 f1
assume par: "par f0 f1"
interpret J: parallel_pair
by unfold_locales
interpret D: parallel_pair_diagram C f0 f1
using par by unfold_locales auto
have 1: "cospan (ECC.prod f1 (dom f0)) (ECC.prod f0 (dom f0))"
using par by simp
let ?g0 = "ECC.prod f0 (dom f0) ⋅ ECC.dup (dom f0)"
let ?g1 = "ECC.prod f1 (dom f1) ⋅ ECC.dup (dom f1)"
have g0: "«?g0 : dom f0 → ECC.prod (cod f0) (dom f0)»"
using par by simp
have g1: "«?g1 : dom f1 → ECC.prod (cod f1) (dom f1)»"
using par by simp
define e0 where "e0 = prj0 ?g1 ?g0"
define e1 where "e1 = prj1 ?g1 ?g0"
have e0: "«e0 : dom e0 → dom f0»"
using par 1 e0_def by auto
have e1: "«e1 : dom e0 → dom f1»"
using par 1 e1_def e0_def by auto
have eq: "e0 = e1"
proof -
have "e1 = prj0' (cod f1) (dom f1) ⋅ ?g1 ⋅ e1"
proof -
have "((prj0' (cod f1) (dom f1) ⋅ (ECC.prod f1 (dom f1))) ⋅ ECC.dup (dom f1)) ⋅ e1 =
dom f1 ⋅ e1"
using par ECC.pr_naturality(1) [of "dom f1" "dom f1" "dom f1" f1 "dom f1" "cod f1"]
comp_cod_arr ECC.pr_dup(1)
by auto
also have "... = e1"
using par e1 comp_cod_arr by blast
finally show ?thesis
using comp_assoc by simp
qed
also have "... = prj0' (cod f1) (dom f1) ⋅ ?g0 ⋅ e0"
using par ECP.pullback_commutes
unfolding commutative_square_def e0_def e1_def by simp
also have "... = e0"
proof -
have "((prj0' (cod f1) (dom f1) ⋅ (ECC.prod f0 (dom f0))) ⋅ ECC.dup (dom f0)) ⋅ e0 =
dom f0 ⋅ e0"
using par ECC.pr_naturality(1) [of "dom f0" "dom f0" "dom f1" f0 "dom f0" "cod f0"]
comp_cod_arr ECC.pr_dup(1) ide_dom
by auto
also have "... = e0"
using e0 comp_cod_arr by blast
finally show ?thesis
using comp_assoc by simp
qed
finally show ?thesis by auto
qed
have equalizes: "D.is_equalized_by e0"
proof
show "seq f0 e0"
using par e0 by auto
show "f0 ⋅ e0 = f1 ⋅ e0"
proof -
have "f0 ⋅ e0 = (f0 ⋅ dom f0) ⋅ e0"
using par comp_arr_dom by simp
also have "... = (f0 ⋅ (prj1' (dom f0) (dom f0) ⋅ ECC.dup (dom f0))) ⋅ e0"
using par ECC.pr_dup(2) by auto
also have "... = ((f0 ⋅ prj1' (dom f0) (dom f0)) ⋅ ECC.dup (dom f0)) ⋅ e0"
using comp_assoc by auto
also have "... = prj1' (cod f1) (dom f1) ⋅ ?g0 ⋅ e0"
using par ECC.pr_naturality(2) [of "dom f0" "dom f0" "dom f1" f0 "dom f0" "cod f0"]
by (metis (no_types, lifting) arr_dom cod_dom dom_dom comp_assoc)
also have "... = prj1' (cod f1) (dom f1) ⋅ ?g1 ⋅ e1"
using par ECP.pullback_commutes [of ?g1 ?g0]
unfolding commutative_square_def e0_def e1_def by simp
also have "... = (prj1' (cod f1) (dom f1) ⋅ ?g1) ⋅ e1"
using comp_assoc by simp
also have "... = (f1 ⋅ (prj1' (dom f1) (dom f1) ⋅ ECC.dup (dom f1))) ⋅ e1"
using par ECC.pr_naturality(2) [of "dom f1" "dom f1" "dom f1" f1 "dom f1" "cod f1"]
by (metis (no_types, lifting) arr_dom cod_dom dom_dom comp_assoc)
also have "... = (f1 ⋅ dom f1) ⋅ e1"
using par ECC.pr_dup(2) by auto
also have "... = f1 ⋅ e1"
using par comp_arr_dom by simp
also have "... = f1 ⋅ e0"
using eq by simp
finally show ?thesis by simp
qed
qed
show "∃e. has_as_equalizer f0 f1 e"
proof
interpret E: constant_functor J.comp C ‹dom e0›
using par e0 by unfold_locales auto
interpret χ: cone J.comp C D.map ‹dom e0› ‹D.mkCone e0›
using equalizes D.cone_mkCone e0_def by auto
interpret χ: limit_cone J.comp C D.map ‹dom e0› ‹D.mkCone e0›
proof
show "⋀a' χ'. D.cone a' χ' ⟹
∃!f. «f : a' → dom e0» ∧ D.cones_map f (D.mkCone e0) = χ'"
proof -
fix a' χ'
assume χ': "D.cone a' χ'"
interpret χ': cone J.comp C D.map a' χ'
using χ' by simp
have 3: "commutative_square ?g1 ?g0 (χ' J.Zero) (χ' J.Zero)"
proof
show "cospan ?g1 ?g0"
using par g0 g1 by simp
show 4: "span (χ' J.Zero) (χ' J.Zero)"
using J.arr_char by simp
show 5: "dom ?g1 = cod (χ' J.Zero)"
using par g1 J.arr_char D.map_def by simp
show "?g1 ⋅ χ' J.Zero = ?g0 ⋅ χ' J.Zero"
proof -
have "?g1 ⋅ χ' J.Zero = ECC.prod f1 (dom f1) ⋅ ECC.dup (dom f1) ⋅ χ' J.Zero"
using comp_assoc by simp
also have "... = ECC.prod f1 (dom f1) ⋅ ECC.tuple (χ' J.Zero) (χ' J.Zero)"
using par D.map_def J.arr_char comp_cod_arr by auto
also have "... = ECC.tuple (f1 ⋅ χ' J.Zero) (χ' J.Zero)"
using par ECC.prod_tuple [of "χ' J.Zero" "χ' J.Zero" f1 "dom f1"]
comp_cod_arr
by (metis (no_types, lifting) 4 5 g1 in_homE seqI)
also have "... = ECC.tuple (f0 ⋅ χ' J.Zero) (χ' J.Zero)"
using par D.is_equalized_by_cone χ'.cone_axioms by auto
also have "... = ECC.prod f0 (dom f0) ⋅ ECC.tuple (χ' J.Zero) (χ' J.Zero)"
using par ECC.prod_tuple [of "χ' J.Zero" "χ' J.Zero" f0 "dom f0"]
comp_cod_arr
by (metis (no_types, lifting) 4 5 g1 in_homE seqI)
also have "... = ECC.prod f0 (dom f0) ⋅ ECC.dup (dom f0) ⋅ χ' J.Zero"
using par D.map_def J.arr_char comp_cod_arr by auto
also have "... = ?g0 ⋅ χ' J.Zero"
using comp_assoc by simp
finally show ?thesis by blast
qed
qed
show "∃!f. «f : a' → dom e0» ∧ D.cones_map f (D.mkCone e0) = χ'"
proof
define f where "f = ECP.tuple (χ' J.Zero) ?g1 ?g0 (χ' J.Zero)"
have 4: "e0 ⋅ f = χ' J.Zero"
using ECP.universal by (simp add: "3" e1_def eq f_def)
have f: "«f : a' → dom e0»"
proof -
have "a' = dom (χ' J.Zero)"
by (simp add: J.arr_char)
thus ?thesis
using 3 f_def e0_def g0 g1 ECP.tuple_in_hom ECP.pbdom_def by simp
qed
moreover have 5: "D.cones_map f (D.mkCone e0) = χ'"
proof -
have "⋀j. J.arr j ⟹ D.mkCone e0 j ⋅ f = χ' j"
proof -
fix j
assume j: "J.arr j"
show "D.mkCone e0 j ⋅ f = χ' j"
proof (cases "j = J.Zero")
case True
moreover have "e0 ⋅ f = χ' J.Zero"
using 4 by simp
ultimately show ?thesis
unfolding f_def D.mkCone_def comp_assoc
using J.arr_char by simp
next
case F: False
hence 1: "(f0 ⋅ e0) ⋅ f = f0 ⋅ χ' J.Zero"
using 4 comp_assoc by simp
also have "... = χ' j"
by (metis (no_types, lifting) F D.mkCone_cone D.mkCone_def
χ'.cone_axioms j)
finally show ?thesis
by (simp add: F D.mkCone_def j)
qed
qed
thus ?thesis
using f e0 χ.cone_axioms χ'.is_extensional by auto
qed
ultimately show "«f : a' → dom e0» ∧ D.cones_map f (D.mkCone e0) = χ'"
by simp
fix f'
assume f': "«f' : a' → dom e0» ∧ D.cones_map f' (D.mkCone e0) = χ'"
show "f' = f"
proof -
have "e0 ⋅ f' = χ' J.Zero"
using f' D.mkCone_cone D.mkCone_def χ'.cone_axioms
comp_assoc J.arr_char χ.cone_axioms
by auto
thus ?thesis
using f' 3 4 eq ECP.universal [of ?g1 ?g0 "e1 ⋅ f'" "e0 ⋅ f'"] e0_def e1_def
by (metis (no_types, lifting))
qed
qed
qed
qed
show "has_as_equalizer f0 f1 e0"
proof -
have "par f0 f1"
by fact
moreover have "D.has_as_equalizer e0"
..
ultimately show ?thesis
using has_as_equalizer_def by blast
qed
qed
qed
interpretation category_with_finite_products C
by (simp add: ECC.is_cartesian_category cartesian_category.is_category_with_finite_products)
lemma has_finite_products:
shows "category_with_finite_products C"
..
lemma has_finite_limits:
shows "category_with_finite_limits C"
proof
fix J :: "nat comp"
assume J: "category J"
interpret J: category J
using J by simp
assume finite: "finite (Collect J.arr)"
show "has_limits_of_shape J"
proof -
have "Collect (partial_magma.ide J) ⊆ Collect J.arr"
by auto
hence 1: "finite (Collect J.ide)"
using finite finite_subset by blast
have "has_products (Collect (partial_magma.ide J))"
using 1 J.ideD(1) J.not_arr_null category_with_finite_products.has_finite_products
is_category_with_finite_products
by simp
moreover have "Collect (partial_magma.ide J) ≠ UNIV"
using J.not_arr_null by blast
moreover have "Collect (partial_magma.arr J) ≠ UNIV"
using J.not_arr_null by blast
ultimately show ?thesis
using finite 1 J.category_axioms has_limits_if_has_products
has_finite_products' [of "Collect J.ide"]
has_finite_products' [of "Collect J.arr"]
by simp
qed
qed
sublocale category_with_finite_limits C
using has_finite_limits by simp
end
end
Theory CartesianClosedCategory
chapter "Cartesian Closed Category"
theory CartesianClosedCategory
imports CartesianCategory
begin
text‹
A \emph{cartesian closed category} is a cartesian category such that,
for every object ‹b›, the functor ‹prod ‐ b› is a left adjoint functor.
A right adjoint to this functor takes each object ‹c› to the \emph{exponential}
‹exp b c›. The adjunction yields a natural bijection between ‹hom (prod a b) c›
and ‹hom a (exp b c)›.
›
locale cartesian_closed_category =
cartesian_category C
for C :: "'a comp" +
assumes left_adjoint_prod: "⋀b. ide b ⟹ left_adjoint_functor C C (λx. prod x b)"
locale elementary_cartesian_closed_category =
elementary_cartesian_category C pr0 pr1 one trm
for C :: "'a ⇒ 'a ⇒ 'a" (infixr ‹⋅› 55)
and pr0 :: "'a ⇒ 'a ⇒ 'a" (‹𝔭⇩0[_, _]›)
and pr1 :: "'a ⇒ 'a ⇒ 'a" (‹𝔭⇩1[_, _]›)
and one :: "'a" (‹𝟭›)
and trm :: "'a ⇒ 'a" (‹𝗍[_]›)
and exp :: "'a ⇒ 'a ⇒ 'a"
and eval :: "'a ⇒ 'a ⇒ 'a"
and Λ :: "'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ 'a" +
assumes eval_in_hom: "⟦ ide b; ide c ⟧ ⟹ «eval b c : prod (exp b c) b → c»"
and ide_exp: "⟦ ide b; ide c ⟧ ⟹ ide (exp b c)"
and lam_in_hom: "⟦ ide a; ide b; ide c; «g : prod a b → c» ⟧ ⟹ «Λ a b c g : a → exp b c»"
and eval_prod_lam: "⟦ ide a; ide b; ide c; «g : prod a b → c» ⟧
⟹ C (eval b c) (prod (Λ a b c g) b) = g"
and lam_eval_prod: "⟦ ide a; ide b; ide c; «h : a → exp b c» ⟧
⟹ Λ a b c (C (eval b c) (prod h b)) = h"
context cartesian_closed_category
begin
lemma has_exponentials:
assumes "ide b" and "ide c"
shows "∃x e. ide x ∧ «e : prod x b → c» ∧
(∀a g. ide a ∧ «g : prod a b → c» ⟶ (∃!f. «f : a → x» ∧ g = C e (prod f b)))"
proof -
interpret F: left_adjoint_functor C C ‹λx. prod x b›
using assms(1) left_adjoint_prod by simp
obtain x e where e: "terminal_arrow_from_functor C C (λx. prod x b) x c e"
using assms F.ex_terminal_arrow [of c] by auto
interpret e: terminal_arrow_from_functor C C ‹λx. prod x b› x c e
using e by simp
have "⋀a g. ⟦ ide a; «g : prod a b → c» ⟧ ⟹ ∃!f. «f : a → x» ∧ g = C e (prod f b)"
using e.is_terminal category_axioms F.functor_axioms
unfolding e.is_coext_def arrow_from_functor_def arrow_from_functor_axioms_def
by simp
thus ?thesis
using e.arrow by metis
qed
definition exp
where "exp b c ≡ SOME x. ide x ∧
(∃e. «e : prod x b → c» ∧
(∀a g. ide a ∧ «g : prod a b → c»
⟶ (∃!f. «f : a → x» ∧ g = C e (prod f b))))"
definition eval
where "eval b c ≡ SOME e. «e : prod (exp b c) b → c» ∧
(∀a g. ide a ∧ «g : prod a b → c»
⟶ (∃!f. «f : a → exp b c» ∧ g = C e (prod f b)))"
definition Λ
where "Λ a b c g ≡ THE f. «f : a → exp b c» ∧ g = C (eval b c) (prod f b)"
lemma ex_un_lam:
assumes "ide b" and "ide c"
shows "ide (exp b c)" and "«eval b c : prod (exp b c) b → c»"
and "⟦ ide a; «g : prod a b → c» ⟧ ⟹ ∃!f. «f : a → exp b c» ∧ g = C (eval b c) (prod f b)"
using assms exp_def eval_def has_exponentials
someI_ex [of "λx. ide x ∧ (∃e. «e : prod x b → c» ∧
(∀a g. ide a ∧ «g : prod a b → c»
⟶ (∃!f. «f : a → x» ∧ g = C e (prod f b))))"]
someI_ex [of "λe. «e : prod (exp b c) b → c» ∧
(∀a g. ide a ∧ «g : prod a b → c»
⟶ (∃!f. «f : a → exp b c» ∧ g = C e (prod f b)))"]
by auto
lemma eval_in_hom [intro]:
assumes "ide b" and "ide c"
shows "«eval b c : prod (exp b c) b → c»"
using assms ex_un_lam by simp
lemma eval_prod_lam:
assumes "ide a" and "ide b" and "ide c" and "«g : prod a b → c»"
shows "«Λ a b c g : a → exp b c» ∧ g = C (eval b c) (prod (Λ a b c g) b)"
using assms Λ_def ex_un_lam
theI' [of "λf. «f : a → exp b c» ∧ g = C (eval b c) (prod f b)"]
by simp
lemma lam_eval_prod:
assumes "ide a" and "ide b" and "ide c" and "«h : a → exp b c»"
shows "Λ a b c (C (eval b c) (prod h b)) = h"
proof -
have "∃!f. «f : a → exp b c» ∧ C (eval b c) (prod h b) = C (eval b c) (prod f b)"
proof -
have "ide a ∧ «C (eval b c) (prod h b) : prod a b → c»"
proof (intro conjI)
show "ide a" by fact
show "«C (eval b c) (prod h b) : prod a b → c»"
using assms by (intro comp_in_homI) auto
qed
thus ?thesis
using assms ex_un_lam by simp
qed
moreover have "«h : a → exp b c» ∧ C (eval b c) (prod h b) = C (eval b c) (prod h b)"
using assms by simp
ultimately show ?thesis
using assms Λ_def ex_un_lam eval_prod_lam
the1_equality [of "λf. «f : a → exp b c» ∧
C (eval b c) (prod h b) = C (eval b c) (prod f b)"]
by simp
qed
interpretation elementary_cartesian_closed_category C pr0 pr1 𝟭 trm exp eval Λ
using eval_in_hom ex_un_lam eval_prod_lam lam_eval_prod
apply unfold_locales by auto
lemma induces_elementary_cartesian_closed_category:
shows "elementary_cartesian_closed_category C pr0 pr1 𝟭 trm exp eval Λ"
..
end
context elementary_cartesian_closed_category
begin
lemma left_adjoint_prod:
assumes "ide b"
shows "left_adjoint_functor C C (λx. x ⊗ b)"
proof -
interpret "functor" C C ‹λx. x ⊗ b›
proof
show "⋀f. ¬ arr f ⟹ f ⊗ b = null"
using tuple_ext prod_def by auto
fix f
show "arr f ⟹ dom (f ⊗ b) = dom f ⊗ b"
using assms by simp
show "arr f ⟹ arr (f ⊗ b)"
using assms by simp
show "arr f ⟹ cod (f ⊗ b) = cod f ⊗ b"
using assms by simp
fix g
show "seq g f ⟹ g ⋅ f ⊗ b = (g ⊗ b) ⋅ (f ⊗ b)"
using assms interchange by simp
qed
interpret left_adjoint_functor C C ‹λx. x ⊗ b›
proof
show "⋀c. ide c ⟹ ∃x e. terminal_arrow_from_functor C C (λx. x ⊗ b) x c e"
proof -
fix c
assume c: "ide c"
show "∃x e. terminal_arrow_from_functor C C (λx. x ⊗ b) x c e"
proof (intro exI)
interpret arrow_from_functor C C ‹λx. x ⊗ b› ‹exp b c› c ‹eval b c›
proof
show "ide (exp b c) ∧ «eval b c : exp b c ⊗ b → c»"
proof (intro conjI)
show "«eval b c : exp b c ⊗ b → c»"
using assms c eval_in_hom by simp
show "ide (exp b c)"
using assms c ide_exp by simp
qed
qed
interpret terminal_arrow_from_functor C C ‹λx. x ⊗ b› ‹exp b c› c ‹eval b c›
proof
show "⋀a f. arrow_from_functor C C (λx. x ⊗ b) a c f ⟹
∃!g. arrow_from_functor.is_coext C C
(λx. x ⊗ b) (exp b c) (eval b c) a f g"
proof -
fix a f
assume f: "arrow_from_functor C C (λx. x ⊗ b) a c f"
interpret f: arrow_from_functor C C ‹λx. x ⊗ b› a c f
using f by simp
show "∃!g. is_coext a f g"
proof
have a: "ide a"
using f.arrow by simp
show "is_coext a f (Λ a b c f)"
unfolding is_coext_def
using assms a c lam_in_hom [of a b c f] eval_prod_lam [of a b c f]
f.arrow
by simp
show "⋀g. is_coext a f g ⟹ g = Λ a b c f"
unfolding is_coext_def
using assms a c lam_eval_prod [of a b c] f.arrow by simp
qed
qed
qed
show "terminal_arrow_from_functor C C (λx. x ⊗ b) (exp b c) c (eval b c)" ..
qed
qed
qed
show ?thesis ..
qed
interpretation CCC: cartesian_category C
using is_cartesian_category by simp
interpretation CCC: cartesian_closed_category C
proof
fix b
assume b: "ide b"
interpret left_adjoint_functor C C ‹λx. CCC.prod x b›
proof -
have "naturally_isomorphic C C (λx. x ⊗ b) (λx. CCC.prod x b)"
proof -
interpret CC: product_category C C ..
interpret X: binary_functor C C C ‹λfg. fst fg ⊗ snd fg›
using binary_functor_Prod(1) by auto
interpret Xb: "functor" C C ‹λx. x ⊗ b›
using b X.fixing_ide_gives_functor_2 by simp
interpret prod: binary_functor C C C ‹λfg. CCC.prod (fst fg) (snd fg)›
using CCC.binary_functor_Prod(1) by simp
interpret prod_b: "functor" C C ‹λx. CCC.prod x b›
using b prod.fixing_ide_gives_functor_2 by simp
interpret φ: transformation_by_components C C ‹λx. x ⊗ b› ‹λx. CCC.prod x b›
‹λa. CCC.tuple (pr1 a b) (pr0 a b)›
using b CCC.prod_tuple by unfold_locales auto
interpret φ: natural_isomorphism C C ‹λx. x ⊗ b› ‹λx. CCC.prod x b› φ.map
proof
fix a
assume a: "ide a"
show "iso (φ.map a)"
proof
show "inverse_arrows (φ.map a) ⟨CCC.pr1 a b, CCC.pr0 a b⟩"
using a b by auto
qed
qed
show ?thesis
using naturally_isomorphic_def φ.natural_isomorphism_axioms by blast
qed
moreover have "left_adjoint_functor C C (λx. x ⊗ b)"
using b left_adjoint_prod [of b] by simp
ultimately show "left_adjoint_functor C C (λx. CCC.prod x b)"
using left_adjoint_functor_respects_naturally_isomorphic by auto
qed
show "⋀f. ¬ arr f ⟹ CCC.prod f b = null"
using is_extensional by blast
show "⋀f. arr f ⟹ dom (CCC.prod f b) = CCC.prod (dom f) b"
by simp
show "⋀f. arr f ⟹ cod (CCC.prod f b) = CCC.prod (cod f) b"
by simp
show "⋀f. arr f ⟹ arr (CCC.prod f b)"
by simp
show "⋀g f. seq g f ⟹ CCC.prod (g ⋅ f) b = CCC.prod g b ⋅ CCC.prod f b"
by simp
show "⋀y. ide y ⟹ ∃x e. terminal_arrow_from_functor (⋅) (⋅) (λx. CCC.prod x b) x y e"
using ex_terminal_arrow by simp
qed
lemma is_cartesian_closed_category:
shows "cartesian_closed_category C"
..
end
end
Theory HFSetCat
chapter "The Category of Hereditarily Finite Sets"
theory HFSetCat
imports CategoryWithFiniteLimits CartesianClosedCategory HereditarilyFinite.HF
begin
text‹
This theory constructs a category whose objects are in bijective correspondence with
the hereditarily finite sets and whose arrows correspond to the functions between such
sets. We show that this category is cartesian closed and has finite limits.
Note that up to this point we have not constructed any other interpretation for the
@{locale cartesian_closed_category} locale, but it is important to have one to ensure
that the locale assumptions are consistent.
›
section "Preliminaries"
text‹
We begin with some preliminary definitions and facts about hereditarily finite sets,
which are better targeted toward what we are trying to do here than what already exists
in @{theory HereditarilyFinite.HF}.
›
text‹
The following defines when a hereditarily finite set ‹F› represents a function from
a hereditarily finite set ‹B› to a hereditarily finite set ‹C›. Specifically, ‹F›
must be a relation from ‹B› to ‹C›, whose domain is ‹B›, whose range is contained in ‹C›,
and which is single-valued on its domain.
›
definition hfun
where "hfun B C F ≡ F ≤ B * C ∧ hfunction F ∧ hdomain F = B ∧ hrange F ≤ C"
lemma hfunI [intro]:
assumes "F ≤ A * B"
and "⋀X. X ❙∈ A ⟹ ∃!Y. ⟨X, Y⟩ ❙∈ F"
and "⋀X Y. ⟨X, Y⟩ ❙∈ F ⟹ Y ❙∈ B"
shows "hfun A B F"
unfolding hfun_def
using assms hfunction_def hrelation_def is_hpair_def hrange_def hconverse_def hdomain_def
apply (intro conjI)
apply auto
by fast
lemma hfunE [elim]:
assumes "hfun B C F"
and "(⋀Y. Y ❙∈ B ⟹ (∃!Z. ⟨Y, Z⟩ ❙∈ F) ∧ (∀Z. ⟨Y, Z⟩ ❙∈ F ⟶ Z ❙∈ C)) ⟹ T"
shows T
proof -
have "⋀Y. Y ❙∈ B ⟹ (∃!Z. ⟨Y, Z⟩ ❙∈ F) ∧ (∀Z. ⟨Y, Z⟩ ❙∈ F ⟶ Z ❙∈ C)"
proof (intro allI impI conjI)
fix Y
assume Y: "Y ❙∈ B"
show "∃!Z. ⟨Y, Z⟩ ❙∈ F"
proof -
have "∃Z. ⟨Y, Z⟩ ❙∈ F"
using assms Y hfun_def hdomain_def by auto
moreover have "⋀Z Z'. ⟦ ⟨Y, Z⟩ ❙∈ F; ⟨Y, Z'⟩ ❙∈ F ⟧ ⟹ Z = Z'"
using assms hfun_def hfunction_def by simp
ultimately show ?thesis by blast
qed
show "⋀Z. ⟨Y, Z⟩ ❙∈ F ⟹ Z ❙∈ C"
using assms Y hfun_def by auto
qed
thus ?thesis
using assms(2) by simp
qed
text‹
The hereditarily finite set ‹hexp B C› represents the collection of all functions
from ‹B› to ‹C›.
›
definition hexp
where "hexp B C = ⦃F ❙∈ HPow (B * C). hfun B C F⦄"
lemma hfun_in_hexp:
assumes "hfun B C F"
shows "F ❙∈ hexp B C"
using assms by (simp add: hexp_def hfun_def)
text‹
The function ‹happ› applies a function ‹F› from ‹B› to ‹C› to an element of ‹B›,
yielding an element of ‹C›.
›
abbreviation happ
where "happ ≡ app"
lemma happ_mapsto:
assumes "F ❙∈ hexp B C" and "Y ❙∈ B"
shows "happ F Y ❙∈ C" and "happ F Y ❙∈ hrange F"
proof -
show "happ F Y ❙∈ C"
using assms app_def hexp_def app_equality hdomain_def hfun_def by auto
show "happ F Y ❙∈ hrange F"
proof -
have "⟨Y, happ F Y⟩ ❙∈ F"
using assms app_def hexp_def app_equality hdomain_def hfun_def by auto
thus ?thesis
using hdomain_def hrange_def hconverse_def by auto
qed
qed
lemma happ_expansion:
assumes "hfun B C F"
shows "F = ⦃XY ❙∈ B * C. hsnd XY = happ F (hfst XY)⦄"
proof
fix XY
show "XY ❙∈ F ⟷ XY ❙∈ ⦃XY ❙∈ B * C. hsnd XY = happ F (hfst XY)⦄"
proof
show "XY ❙∈ F ⟹ XY ❙∈ ⦃XY ❙∈ B * C. hsnd XY = happ F (hfst XY)⦄"
proof -
assume XY: "XY ❙∈ F"
have "XY ❙∈ B * C"
using assms XY hfun_def by auto
moreover have "hsnd XY = happ F (hfst XY)"
using assms XY hfunE app_def [of F "hfst XY"] the1_equality [of "λy. ⟨hfst XY, y⟩ ❙∈ F"]
calculation
by auto
ultimately show "XY ❙∈ ⦃XY ❙∈ B * C. hsnd XY = happ F (hfst XY)⦄" by simp
qed
show "XY ❙∈ ⦃XY ❙∈ B * C. hsnd XY = happ F (hfst XY)⦄ ⟹ XY ❙∈ F"
proof -
assume XY: "XY ❙∈ ⦃XY ❙∈ B * C. hsnd XY = happ F (hfst XY)⦄"
show "XY ❙∈ F"
using assms XY app_def [of F "hfst XY"] the1_equality [of "λy. ⟨hfst XY, y⟩ ❙∈ F"]
by fastforce
qed
qed
qed
text‹
Function ‹hlam› takes a function ‹F› from ‹A * B› to ‹C› to a function ‹hlam F›
from ‹A› to ‹hexp B C›.
›
definition hlam
where "hlam A B C F =
⦃XG ❙∈ A * hexp B C.
∀YZ. YZ ❙∈ hsnd XG ⟷ is_hpair YZ ∧ ⟨⟨hfst XG, hfst YZ⟩, hsnd YZ⟩ ❙∈ F⦄"
lemma hfun_hlam:
assumes "hfun (A * B) C F"
shows "hfun A (hexp B C) (hlam A B C F)"
proof
show "hlam A B C F ≤ A * hexp B C"
using assms hlam_def by auto
show "⋀X. X ❙∈ A ⟹ ∃!Y. ⟨X, Y⟩ ❙∈ hlam A B C F"
proof
fix X
assume X: "X ❙∈ A"
let ?G = "⦃YZ ❙∈ B * C. ⟨⟨X, hfst YZ⟩, hsnd YZ⟩ ❙∈ F⦄"
have 1: "?G ❙∈ hexp B C"
using assms X hexp_def by fastforce
show "⟨X, ?G⟩ ❙∈ hlam A B C F"
using assms X 1 is_hpair_def hfun_def hlam_def by auto
fix Y
assume XY: "⟨X, Y⟩ ❙∈ hlam A B C F"
show "Y = ?G"
using assms X XY hlam_def hexp_def by fastforce
qed
show "⋀X Y. ⟨X, Y⟩ ❙∈ hlam A B C F ⟹ Y ❙∈ hexp B C"
using assms hlam_def hexp_def by simp
qed
lemma happ_hlam:
assumes "X ❙∈ A" and "hfun (A * B) C F"
shows "∃!G. ⟨X, G⟩ ❙∈ hlam A B C F"
and "happ (hlam A B C F) X = (THE G. ⟨X, G⟩ ❙∈ hlam A B C F)"
and "happ (hlam A B C F) X = ⦃yz ❙∈ B * C. ⟨⟨X, hfst yz⟩, hsnd yz⟩ ❙∈ F⦄"
and "Y ❙∈ B ⟹ happ (happ (hlam A B C F) X) Y = happ F ⟨X, Y⟩"
proof -
show 1: "∃!G. ⟨X, G⟩ ❙∈ hlam A B C F"
using assms(1,2) hfun_hlam hfunE
by (metis (full_types))
show 2: "happ (hlam A B C F) X = (THE G. ⟨X, G⟩ ❙∈ hlam A B C F)"
using assms app_def by simp
show "happ (happ (hlam A B C F) X) Y = happ F ⟨X, Y⟩"
proof -
have 3: "⟨X, happ (hlam A B C F) X⟩ ❙∈ hlam A B C F"
using assms(1) 1 2 theI' [of "λG. ⟨X, G⟩ ❙∈ hlam A B C F"] by simp
hence "∃!Z. happ (happ (hlam A B C F) X) = Z"
by simp
moreover have "happ (happ (hlam A B C F) X) Y = happ F ⟨X, Y⟩"
using assms(1-2) 3 hlam_def is_hpair_def app_def by simp
ultimately show ?thesis by simp
qed
show "happ (hlam A B C F) X = ⦃YZ ❙∈ B * C. ⟨⟨X, hfst YZ⟩, hsnd YZ⟩ ❙∈ F⦄"
proof -
let ?G = "⦃YZ ❙∈ B * C. ⟨⟨X, hfst YZ⟩, hsnd YZ⟩ ❙∈ F⦄"
have 4: "hfun B C ?G"
proof
show "⦃YZ ❙∈ B * C. ⟨⟨X, hfst YZ⟩, hsnd YZ⟩ ❙∈ F⦄ ≤ B * C"
using assms by auto
show "⋀Y. Y ❙∈ B ⟹ ∃!Z. ⟨Y, Z⟩ ❙∈ ⦃YZ ❙∈ B * C. ⟨⟨X, hfst YZ⟩, hsnd YZ⟩ ❙∈ F⦄"
proof -
fix Y
assume Y: "Y ❙∈ B"
have XY: "⟨X, Y⟩ ❙∈ A * B"
using assms Y by simp
hence 1: "∃!Z. ⟨⟨X, Y⟩, Z⟩ ❙∈ F"
using assms XY hfunE [of "A * B" C F] by blast
obtain Z where Z: "⟨⟨X, Y⟩, Z⟩ ❙∈ F"
using 1 by auto
have "∃Z. ⟨Y, Z⟩ ❙∈ ⦃YZ ❙∈ B * C. ⟨⟨X, hfst YZ⟩, hsnd YZ⟩ ❙∈ F⦄"
proof -
have "⟨Y, Z⟩ ❙∈ B * C"
using assms Y Z by blast
moreover have "⟨⟨X, hfst ⟨Y, Z⟩⟩, hsnd ⟨Y, Z⟩⟩ ❙∈ F"
using assms Y Z by simp
ultimately show ?thesis by auto
qed
moreover have "⋀Z Z'. ⟦⟨Y, Z⟩ ❙∈ ⦃YZ ❙∈ B * C. ⟨⟨X, hfst YZ⟩, hsnd YZ⟩ ❙∈ F⦄;
⟨Y, Z'⟩ ❙∈ ⦃YZ ❙∈ B * C. ⟨⟨X, hfst YZ⟩, hsnd YZ⟩ ❙∈ F⦄⟧ ⟹ Z = Z'"
using assms Y by auto
ultimately show "∃!Z. ⟨Y, Z⟩ ❙∈ ⦃YZ ❙∈ B * C. ⟨⟨X, hfst YZ⟩, hsnd YZ⟩ ❙∈ F⦄"
by auto
qed
show "⋀Y Z. ⟨Y, Z⟩ ❙∈ ⦃YZ ❙∈ B * C. ⟨⟨X, hfst YZ⟩, hsnd YZ⟩ ❙∈ F⦄ ⟹ Z ❙∈ C"
using assms by simp
qed
have "⟨X, ?G⟩ ❙∈ hlam A B C F"
proof -
have "⟨X, ?G⟩ ❙∈ A * hexp B C"
using assms 4
by (simp add: hfun_in_hexp)
moreover have "∀YZ. YZ ❙∈ ?G ⟷ is_hpair YZ ∧ ⟨⟨X, hfst YZ⟩, hsnd YZ⟩ ❙∈ F"
using assms 1 is_hpair_def hfun_def by auto
ultimately show ?thesis
using assms 1 hlam_def by simp
qed
thus "happ (hlam A B C F) X = ?G"
using assms 2 4 app_equality hfun_def hfun_hlam by auto
qed
qed
section "Construction of the Category"
locale hfsetcat
begin
text‹
We construct the category of hereditarily finite sets and function simply by applying
the generic ``set category'' construction, using the hereditarily finite sets as the
universe, and constraining the collections of such sets that determine objects of the
category to those having cardinality less than that of the natural numbers;
\emph{i.e.}~to those that are finite.
›
interpretation setcat ‹undefined :: hf› natLeq
using Field_natLeq natLeq_Card_order
by unfold_locales auto
interpretation category_with_terminal_object comp
using terminal_unity by unfold_locales auto
text‹
We verify that the objects of HF are indeed in bijective correspondence with the
hereditarily finite sets.
›
definition ide_to_hf
where "ide_to_hf a = HF (DOWN ` set a)"
definition hf_to_ide
where "hf_to_ide x = mkIde (UP ` hfset x)"
lemma ide_to_hf_mapsto:
shows "ide_to_hf ∈ Collect ide → UNIV"
by simp
lemma hf_to_ide_mapsto:
shows "hf_to_ide ∈ UNIV → Collect ide"
proof
fix x :: hf
have "finite (UP ` hfset x)"
by simp
moreover have "UP ` hfset x ⊆ Univ"
by (metis (mono_tags, lifting) UNIV_I bij_UP bij_betw_def imageE image_eqI subsetI)
ultimately have "ide (mkIde (UP ` hfset x))"
using ide_mkIde_finite by simp
thus "hf_to_ide x ∈ Collect ide"
using hf_to_ide_def by simp
qed
lemma hf_to_ide_ide_to_hf:
assumes "a ∈ Collect ide"
shows "hf_to_ide (ide_to_hf a) = a"
proof -
have "hf_to_ide (ide_to_hf a) = mkIde (UP ` hfset (HF (DOWN ` set a)))"
using hf_to_ide_def ide_to_hf_def by simp
also have "... = a"
proof -
have "mkIde (UP ` hfset (HF (DOWN ` set a))) = mkIde (UP ` DOWN ` set a)"
proof -
have "finite (set a)"
using assms set_card finite_iff_ordLess_natLeq by auto
hence "finite (DOWN ` set a)"
by simp
hence "hfset (HF (DOWN ` set a)) = DOWN ` set a"
using hfset_HF [of "DOWN ` set a"] by simp
thus ?thesis by simp
qed
also have "... = a"
proof -
have "set a ⊆ Univ"
using assms set_subset_Univ ide_char by blast
hence "⋀x. x ∈ set a ⟹ UP (DOWN x) = x"
using assms by auto
hence "UP ` DOWN ` set a = set a"
by force
thus ?thesis
using assms ide_char mkIde_set by simp
qed
finally show ?thesis by blast
qed
finally show "hf_to_ide (ide_to_hf a) = a" by blast
qed
lemma ide_to_hf_hf_to_ide:
assumes "x ∈ UNIV"
shows "ide_to_hf (hf_to_ide x) = x"
proof -
have "HF (DOWN ` set (mkIde (UP ` hfset x))) = x"
proof -
have "HF (DOWN ` set (mkIde (UP ` hfset x))) = HF (DOWN ` UP ` hfset x)"
proof -
have "|UP ` hfset x| <o natLeq"
using assms finite_iff_ordLess_natLeq finite_hfset by blast
thus ?thesis
using assms set_mkIde [of "UP ` hfset x"] UP_mapsto mkIde_def by auto
qed
also have "... = HF (hfset x)"
proof -
have "⋀A. DOWN ` UP ` A = A"
using DOWN_UP by force
thus ?thesis by metis
qed
also have "... = x" by simp
finally show ?thesis by blast
qed
thus ?thesis
using assms ide_to_hf_def hf_to_ide_def by simp
qed
lemma bij_betw_ide_hf_set:
shows "bij_betw ide_to_hf (Collect ide) (UNIV :: hf set)"
using ide_to_hf_mapsto hf_to_ide_mapsto ide_to_hf_hf_to_ide hf_to_ide_ide_to_hf
by (intro bij_betwI) auto
lemma ide_implies_finite_set:
assumes "ide a"
shows "finite (set a)" and "finite (hom unity a)"
proof -
show 1: "finite (set a)"
using assms ide_char set_card finite_iff_ordLess_natLeq by blast
show "finite (hom unity a)"
proof -
have "|hom unity a| =o |set a|"
using assms bij_betw_points_and_set card_of_ordIsoI by auto
thus ?thesis
using 1 by simp
qed
qed
text‹
We establish the connection between the membership relation defined for hereditarily
finite sets and the corresponding membership relation associated with the set category.
›
lemma UP_membI [intro]:
assumes "x ❙∈ ide_to_hf a"
shows "UP x ∈ set a"
proof -
let ?X = "inv_into (set a) DOWN x"
have "x = DOWN ?X ∧ ?X ∈ set a"
using assms
by (simp add: f_inv_into_f ide_to_hf_def inv_into_into)
thus ?thesis
by (metis (no_types, lifting) UP_DOWN elem_set_implies_incl_in incl_in_def
set_subset_Univ subsetD)
qed
lemma DOWN_membI [intro]:
assumes "ide a" and "x ∈ set a"
shows "DOWN x ❙∈ ide_to_hf a"
proof -
have "finite (DOWN ` set a)"
using assms ide_implies_finite_set [of a] by simp
hence "DOWN x ∈ hfset (ide_to_hf a)"
using assms ide_to_hf_def hfset_HF [of "DOWN ` set a"] by simp
thus ?thesis
using hmem_def by blast
qed
text‹
We show that each hom-set ‹hom a b› is in bijective correspondence with
the elements of the hereditarily finite set ‹hfun (ide_to_hf a) (ide_to_hf b)›.
›
definition arr_to_hfun
where "arr_to_hfun f = ⦃XY ❙∈ ide_to_hf (dom f) * ide_to_hf (cod f).
hsnd XY = DOWN (Fun f (UP (hfst XY)))⦄"
definition hfun_to_arr
where "hfun_to_arr B C F =
mkArr (UP ` hfset B) (UP ` hfset C) (λx. UP (happ F (DOWN x)))"
lemma hfun_arr_to_hfun:
assumes "arr f"
shows "hfun (ide_to_hf (dom f)) (ide_to_hf (cod f)) (arr_to_hfun f)"
proof
show "arr_to_hfun f ≤ ide_to_hf (dom f) * ide_to_hf (cod f)"
using assms arr_to_hfun_def by auto
show "⋀X. X ❙∈ ide_to_hf (dom f) ⟹ ∃!Y. ⟨X, Y⟩ ❙∈ arr_to_hfun f"
proof
fix X
assume X: "X ❙∈ ide_to_hf (dom f)"
show "⟨X, DOWN (Fun f (UP X))⟩ ❙∈ arr_to_hfun f"
proof -
have "⟨X, DOWN (Fun f (UP X))⟩ ❙∈ ⦃XY ❙∈ ide_to_hf (dom f) * ide_to_hf (cod f).
hsnd XY = DOWN (Fun f (UP (hfst XY)))⦄"
proof -
have "hsnd ⟨X, DOWN (Fun f (UP X))⟩ =
DOWN (Fun f (UP (hfst ⟨X, DOWN (Fun f (UP X))⟩)))"
using assms X by simp
moreover have "⟨X, DOWN (Fun f (UP X))⟩ ❙∈ ide_to_hf (dom f) * ide_to_hf (cod f)"
proof -
have "DOWN (Fun f (UP X)) ❙∈ ide_to_hf (cod f)"
proof (intro DOWN_membI)
show "ide (cod f)"
using assms ide_cod by simp
show "Fun f (UP X) ∈ Cod f"
using assms X Fun_mapsto UP_membI by auto
qed
thus ?thesis
using X by simp
qed
ultimately show ?thesis by simp
qed
thus ?thesis
using arr_to_hfun_def by simp
qed
fix Y
assume XY: "⟨X, Y⟩ ❙∈ arr_to_hfun f"
show "Y = DOWN (Fun f (UP X))"
using assms X XY arr_to_hfun_def by auto
qed
show "⋀X Y. ⟨X, Y⟩ ❙∈ arr_to_hfun f ⟹ Y ❙∈ ide_to_hf (cod f)"
using assms arr_to_hfun_def ide_to_hf_def
‹arr_to_hfun f ≤ ide_to_hf (dom f) * ide_to_hf (cod f)›
by blast
qed
lemma arr_to_hfun_in_hexp:
assumes "arr f"
shows "arr_to_hfun f ❙∈ hexp (ide_to_hf (dom f)) (ide_to_hf (cod f))"
using assms arr_to_hfun_def hfun_arr_to_hfun hexp_def by auto
lemma hfun_to_arr_in_hom:
assumes "hfun B C F"
shows "«hfun_to_arr B C F : hf_to_ide B → hf_to_ide C»"
proof
let ?f = "mkArr (UP ` hfset B) (UP ` hfset C) (λx. UP (happ F (DOWN x)))"
have 0: "arr ?f"
proof -
have "UP ` hfset B ⊆ Univ ∧ UP ` hfset C ⊆ Univ"
using UP_mapsto by auto
moreover have "(λx. UP (happ F (DOWN x))) ∈ UP ` hfset B → UP ` hfset C"
proof
fix x
assume x: "x ∈ UP ` hfset B"
have "happ F (DOWN x) ∈ hfset C"
using assms x happ_mapsto hfun_in_hexp
by (metis DOWN_UP HF_hfset finite_hfset hmem_HF_iff imageE)
thus "UP (happ F (DOWN x)) ∈ UP ` hfset C"
by simp
qed
ultimately show ?thesis
using arr_mkArr
by (meson finite_hfset finite_iff_ordLess_natLeq finite_imageI)
qed
show 1: "arr (hfun_to_arr B C F)"
using 0 hfun_to_arr_def by simp
show "dom (hfun_to_arr B C F) = hf_to_ide B"
using 1 hfun_to_arr_def hf_to_ide_def dom_mkArr by auto
show "cod (hfun_to_arr B C F) = hf_to_ide C"
using 1 hfun_to_arr_def hf_to_ide_def cod_mkArr by auto
qed
text‹
The comprehension notation from @{theory HereditarilyFinite.HF} interferes in an
unfortunate way with the restriction notation from @{theory "HOL-Library.FuncSet"},
making it impossible to use both in the present context.
›
lemma Fun_char:
assumes "arr f"
shows "Fun f = restrict (λx. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f)"
proof
fix x
show "Fun f x = restrict (λx. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f) x"
proof (cases "x ∈ Dom f")
show "x ∉ Dom f ⟹ ?thesis"
using assms Fun_mapsto Fun_def restrict_apply by simp
show "x ∈ Dom f ⟹ ?thesis"
proof -
assume x: "x ∈ Dom f"
have 1: "hfun (ide_to_hf (dom f)) (ide_to_hf (cod f)) (arr_to_hfun f)"
using assms app_def arr_to_hfun_def hfun_arr_to_hfun
the1_equality [of "λy. ⟨DOWN x, y⟩ ❙∈ arr_to_hfun f" "DOWN (Fun f x)"]
by simp
have 2: "∃!Y. ⟨DOWN x, Y⟩ ❙∈ arr_to_hfun f"
using assms x 1 hfunE DOWN_membI ide_dom
by (metis (no_types, lifting))
have "Fun f x = UP (DOWN (Fun f x))"
proof -
have "Fun f x ∈ Univ"
using assms x ide_cod Fun_mapsto [of f] set_subset_Univ by auto
thus ?thesis
using UP_DOWN by simp
qed
also have "... = UP (happ (arr_to_hfun f) (DOWN x))"
proof -
have "⟨DOWN x, DOWN (Fun f x)⟩ ❙∈ arr_to_hfun f"
using assms x 2 ide_dom arr_to_hfun_def set_subset_Univ UP_DOWN
by (metis (mono_tags, lifting) HCollectE hfst_conv hsnd_conv subsetD)
moreover have "⟨DOWN x, happ (arr_to_hfun f) (DOWN x)⟩ ❙∈ arr_to_hfun f"
using assms x 1 2 app_equality hfun_def by blast
ultimately show ?thesis
using 2 by fastforce
qed
also have "... = restrict (λx. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f) x"
using assms x ide_dom by auto
finally show ?thesis by simp
qed
qed
qed
lemma Fun_hfun_to_arr:
assumes "hfun B C F"
shows "Fun (hfun_to_arr B C F) = restrict (λx. UP (happ F (DOWN x))) (UP ` hfset B)"
proof -
have "arr (hfun_to_arr B C F)"
using assms hfun_to_arr_in_hom by blast
hence "arr (mkArr (UP ` hfset B) (UP ` hfset C) (λx. UP (happ F (DOWN x))))"
using hfun_to_arr_def by simp
thus ?thesis
using assms hfun_to_arr_def Fun_mkArr by simp
qed
lemma UP_img_hfset_ide_to_hf:
assumes "ide a"
shows "UP ` hfset (ide_to_hf a) = set a"
proof -
have "UP ` hfset (ide_to_hf a) = UP ` hfset (HF (DOWN ` set a))"
using ide_to_hf_def by simp
also have "... = UP ` DOWN ` set a"
using assms ide_implies_finite_set(1) ide_char by auto
also have "... = set a"
proof -
have "⋀x. x ∈ set a ⟹ UP (DOWN x) = x"
using assms ide_char
by (metis (no_types, lifting) UP_DOWN set_subset_Univ subsetD)
thus ?thesis by force
qed
finally show ?thesis by blast
qed
lemma hfun_to_arr_arr_to_hfun:
assumes "arr f"
shows "hfun_to_arr (ide_to_hf (dom f)) (ide_to_hf (cod f)) (arr_to_hfun f) = f"
proof -
have 0: "hfun_to_arr (ide_to_hf (dom f)) (ide_to_hf (cod f)) (arr_to_hfun f) =
mkArr (UP ` hfset (ide_to_hf (dom f))) (UP ` hfset (ide_to_hf (cod f)))
(λx. UP (happ (arr_to_hfun f) (DOWN x)))"
unfolding hfun_to_arr_def by blast
also have "... = mkArr (Dom f) (Cod f)
(restrict (λx. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f))"
proof (intro mkArr_eqI)
show 1: "UP ` hfset (ide_to_hf (dom f)) = Dom f"
using assms UP_img_hfset_ide_to_hf ide_dom by simp
show 2: "UP ` hfset (ide_to_hf (cod f)) = Cod f"
using assms UP_img_hfset_ide_to_hf ide_cod by simp
show "arr (mkArr (UP ` hfset (ide_to_hf (dom f))) (UP ` hfset (ide_to_hf (cod f)))
(λx. UP (happ (arr_to_hfun f) (DOWN x))))"
using 0 1 2
by (metis (no_types, lifting) arrI assms hfun_arr_to_hfun hfun_to_arr_in_hom)
show "⋀x. x ∈ UP ` hfset (ide_to_hf (dom f)) ⟹
UP (happ (arr_to_hfun f) (DOWN x)) =
restrict (λx. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f) x"
using assms 1 by simp
qed
also have "... = mkArr (Dom f) (Cod f) (Fun f)"
using assms Fun_char mkArr_eqI by simp
also have "... = f"
using assms mkArr_Fun by blast
finally show ?thesis by simp
qed
lemma arr_to_hfun_hfun_to_arr:
assumes "hfun B C F"
shows "arr_to_hfun (hfun_to_arr B C F) = F"
proof -
have "arr_to_hfun (hfun_to_arr B C F) =
⦃XY ❙∈ ide_to_hf (dom (hfun_to_arr B C F)) * ide_to_hf (cod (hfun_to_arr B C F)).
hsnd XY = DOWN (Fun (hfun_to_arr B C F) (UP (hfst XY)))⦄"
unfolding arr_to_hfun_def by blast
also have
"... = ⦃XY ❙∈ ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)).
hsnd XY = DOWN (Fun (hfun_to_arr B C F) (UP (hfst XY)))⦄"
using assms hfun_to_arr_in_hom [of B C F] hf_to_ide_def
by (metis (no_types, lifting) in_homE)
also have
"... = ⦃XY ❙∈ ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)).
hsnd XY = DOWN (restrict (λx. UP (happ F (DOWN x))) (UP ` hfset B)
(UP (hfst XY)))⦄"
using assms Fun_hfun_to_arr by simp
also have
"... = ⦃XY ❙∈ ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)).
hsnd XY = DOWN (UP (happ F (DOWN (UP (hfst XY)))))⦄"
proof -
have
1: "⋀XY. XY ❙∈ ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C))
⟹ UP (hfst XY) ∈ UP ` hfset B"
proof -
fix XY
assume
XY: "XY ❙∈ ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C))"
have "hfst XY ❙∈ ide_to_hf (mkIde (UP ` hfset B))"
using XY by auto
thus "UP (hfst XY) ∈ UP ` hfset B"
using assms UP_membI [of "hfst XY" "mkIde (UP ` hfset B)"] set_mkIde
by (metis (mono_tags, lifting) arrI arr_mkArr hfun_to_arr_def hfun_to_arr_in_hom)
qed
show ?thesis
proof -
have
"⋀XY. (XY ❙∈ ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)) ∧
hsnd XY = DOWN (restrict (λx. UP (happ F (DOWN x))) (UP ` hfset B)
(UP (hfst XY))))
⟷
(XY ❙∈ ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)) ∧
hsnd XY = DOWN (UP (happ F (DOWN (UP (hfst XY))))))"
using 1 by auto
thus ?thesis by blast
qed
qed
also have
"... = ⦃XY ❙∈ ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)).
hsnd XY = happ F (hfst XY)⦄"
by simp
also have "... = ⦃XY ❙∈ B * C. hsnd XY = happ F (hfst XY)⦄"
using assms hf_to_ide_def ide_to_hf_hf_to_ide by force
also have "... = F"
using assms happ_expansion by simp
finally show ?thesis by simp
qed
lemma bij_betw_hom_hfun:
assumes "ide a" and "ide b"
shows "bij_betw arr_to_hfun (hom a b) {F. hfun (ide_to_hf a) (ide_to_hf b) F}"
proof (intro bij_betwI)
show "arr_to_hfun ∈ hom a b → {F. hfun (ide_to_hf a) (ide_to_hf b) F}"
using assms arr_to_hfun_in_hexp hexp_def hfun_arr_to_hfun by blast
show "hfun_to_arr (ide_to_hf a) (ide_to_hf b)
∈ {F. hfun (ide_to_hf a) (ide_to_hf b) F} → hom a b"
using assms hfun_to_arr_in_hom
by (metis (no_types, lifting) Pi_I hf_to_ide_ide_to_hf mem_Collect_eq)
show "⋀x. x ∈ hom a b ⟹ hfun_to_arr (ide_to_hf a) (ide_to_hf b) (arr_to_hfun x) = x"
using assms hfun_to_arr_arr_to_hfun by blast
show "⋀y. y ∈ {F. hfun (ide_to_hf a) (ide_to_hf b) F} ⟹
arr_to_hfun (hfun_to_arr (ide_to_hf a) (ide_to_hf b) y) = y"
using assms arr_to_hfun_hfun_to_arr by simp
qed
text‹
We next relate composition of arrows in the category to the corresponding operation
on hereditarily finite sets.
›
definition hcomp
where "hcomp G F =
⦃XZ ❙∈ hdomain F * hrange G. hsnd XZ = happ G (happ F (hfst XZ))⦄"
lemma hfun_hcomp:
assumes "hfun A B F" and "hfun B C G"
shows "hfun A C (hcomp G F)"
proof
show "hcomp G F ≤ A * C"
using assms hcomp_def hfun_def by auto
show "⋀X. X ❙∈ A ⟹ ∃!Y. ⟨X, Y⟩ ❙∈ hcomp G F"
proof
fix X
assume X: "X ❙∈ A"
show "⟨X, happ G (happ F X)⟩ ❙∈ hcomp G F"
unfolding hcomp_def
using assms X hfunE happ_mapsto hfun_in_hexp
by (metis (mono_tags, lifting) HCollect_iff hfst_conv hfun_def hsnd_conv timesI)
show "⋀X Y. ⟦X ❙∈ A; ⟨X, Y⟩ ❙∈ hcomp G F⟧ ⟹ Y = happ G (happ F X)"
unfolding hcomp_def by simp
qed
show "⋀X Y. ⟨X, Y⟩ ❙∈ hcomp G F ⟹ Y ❙∈ C"
unfolding hcomp_def
using assms hfunE happ_mapsto hfun_in_hexp
by (metis HCollectE hfun_def hsubsetCE timesD2)
qed
lemma arr_to_hfun_comp:
assumes "seq g f"
shows "arr_to_hfun (comp g f) = hcomp (arr_to_hfun g) (arr_to_hfun f)"
proof -
have 1: "hdomain (arr_to_hfun f) = ide_to_hf (dom f)"
using assms hfun_arr_to_hfun hfun_def by blast
have "arr_to_hfun (comp g f) =
⦃XZ ❙∈ ide_to_hf (dom f) * ide_to_hf (cod g).
hsnd XZ = DOWN (Fun (comp g f) (UP (hfst XZ)))⦄"
unfolding arr_to_hfun_def comp_def
using assms by fastforce
also have "... = ⦃XZ ❙∈ hdomain (arr_to_hfun f) * hrange (arr_to_hfun g).
hsnd XZ = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))⦄"
proof
fix XZ
have "hfst XZ ❙∈ hdomain (arr_to_hfun f)
⟹ hsnd XZ ❙∈ ide_to_hf (cod g) ∧
hsnd XZ = DOWN (Fun (comp g f) (UP (hfst XZ)))
⟷
hsnd XZ ❙∈ hrange (arr_to_hfun g) ∧
hsnd XZ = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))"
proof
assume XZ: "hfst XZ ❙∈ hdomain (arr_to_hfun f)"
have 2: "UP (hfst XZ) ∈ Dom f"
using XZ 1 hfsetcat.UP_membI by auto
have 3: "UP (happ (arr_to_hfun f) (hfst XZ)) ∈ Dom g"
using assms XZ 2
by (metis (no_types, lifting) "1" happ_mapsto(1) hfsetcat.UP_membI
arr_to_hfun_in_hexp seqE)
have 4: "DOWN (Fun (comp g f) (UP (hfst XZ))) =
happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))"
proof -
have "DOWN (Fun (comp g f) (UP (hfst XZ))) =
DOWN (restrict (Fun g o Fun f) (Dom f) (UP (hfst XZ)))"
using assms Fun_comp Fun_char by simp
also have "... = DOWN ((Fun g o Fun f) (UP (hfst XZ)))"
using XZ 2 by auto
also have "... = DOWN (Fun g (Fun f (UP (hfst XZ))))"
by simp
also have
"... = DOWN (Fun g (restrict (λx. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f)
(UP (hfst XZ))))"
proof -
have "Fun f = restrict (λx. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f)"
using assms Fun_char [of f] by blast
thus ?thesis by simp
qed
also have "... = DOWN (Fun g (UP (happ (arr_to_hfun f) (hfst XZ))))"
using 2 by simp
also have "... = DOWN (restrict (λx. UP (happ (arr_to_hfun g) (DOWN x))) (Dom g)
(UP (happ (arr_to_hfun f) (hfst XZ))))"
proof -
have "Fun g = restrict (λx. UP (happ (arr_to_hfun g) (DOWN x))) (Dom g)"
using assms Fun_char [of g] by blast
thus ?thesis by simp
qed
also have "... = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))"
using 3 by simp
finally show ?thesis by blast
qed
have 5: "DOWN (Fun (comp g f) (UP (hfst XZ))) ❙∈ hrange (arr_to_hfun g)"
proof -
have "happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ)) ❙∈ hrange (arr_to_hfun g)"
using assms 1 3 XZ hfun_arr_to_hfun happ_mapsto arr_to_hfun_in_hexp arr_to_hfun_def
by (metis (no_types, lifting) seqE)
thus ?thesis
using XZ 4 by simp
qed
show "hsnd XZ ❙∈ ide_to_hf (cod g) ∧
hsnd XZ = DOWN (Fun (comp g f) (UP (hfst XZ)))
⟹
hsnd XZ ❙∈ hrange (arr_to_hfun g) ∧
hsnd XZ = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))"
using XZ 4 5 by simp
show "hsnd XZ ❙∈ hrange (arr_to_hfun g) ∧
hsnd XZ = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))
⟹
hsnd XZ ❙∈ ide_to_hf (cod g) ∧
hsnd XZ = DOWN (Fun (comp g f) (UP (hfst XZ)))"
using assms XZ 1 4
by (metis (no_types, lifting) arr_to_hfun_in_hexp happ_mapsto(1) seqE)
qed
thus "XZ ❙∈ ⦃XZ ❙∈ ide_to_hf (dom f) * ide_to_hf (cod g).
hsnd XZ = DOWN (Fun (comp g f) (UP (hfst XZ)))⦄
⟷
XZ ❙∈ ⦃XZ ❙∈ hdomain (arr_to_hfun f) * hrange (arr_to_hfun g).
hsnd XZ = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))⦄"
using 1 is_hpair_def by auto
qed
also have "... = hcomp (arr_to_hfun g) (arr_to_hfun f)"
using assms arr_to_hfun_def hcomp_def by simp
finally show ?thesis by simp
qed
lemma hfun_to_arr_hcomp:
assumes "hfun A B F" and "hfun B C G"
shows "hfun_to_arr A C (hcomp G F) = comp (hfun_to_arr B C G) (hfun_to_arr A B F)"
proof -
have 1: "arr_to_hfun (hfun_to_arr A C (hcomp G F)) =
arr_to_hfun (comp (hfun_to_arr B C G) (hfun_to_arr A B F))"
proof -
have "arr_to_hfun (comp (hfun_to_arr B C G) (hfun_to_arr A B F)) =
hcomp (arr_to_hfun (hfun_to_arr B C G)) (arr_to_hfun (hfun_to_arr A B F))"
using assms arr_to_hfun_comp hfun_to_arr_in_hom by blast
also have "... = hcomp G F"
using assms by (simp add: arr_to_hfun_hfun_to_arr)
also have "... = arr_to_hfun (hfun_to_arr A C (hcomp G F))"
proof -
have "hfun A C (hcomp G F)"
using assms hfun_hcomp by simp
thus ?thesis
by (simp add: arr_to_hfun_hfun_to_arr)
qed
finally show ?thesis by simp
qed
show ?thesis
proof -
have "hfun_to_arr A C (hcomp G F) ∈ hom (hf_to_ide A) (hf_to_ide C)"
using assms hfun_hcomp hf_to_ide_def hfun_to_arr_in_hom by auto
moreover have "comp (hfun_to_arr B C G) (hfun_to_arr A B F)
∈ hom (hf_to_ide A) (hf_to_ide C)"
using assms hfun_to_arr_in_hom hf_to_ide_def
by (metis (no_types, lifting) comp_in_homI mem_Collect_eq)
moreover have "inj_on arr_to_hfun (hom (hf_to_ide A) (hf_to_ide C))"
proof -
have "ide (hf_to_ide A) ∧ ide (hf_to_ide C)"
using assms hf_to_ide_mapsto by auto
thus ?thesis
using bij_betw_hom_hfun [of "hf_to_ide A" "hf_to_ide C"] bij_betw_imp_inj_on
by auto
qed
ultimately show ?thesis
using 1 inj_on_def [of arr_to_hfun "hom (hf_to_ide A) (hf_to_ide C)"] by simp
qed
qed
section "Binary Products"
text‹
The category of hereditarily finite sets has binary products,
given by cartesian product of sets in the usual way.
›
definition prod
where "prod a b = hf_to_ide (ide_to_hf a * ide_to_hf b)"
definition pr0
where "pr0 a b = (if ide a ∧ ide b then
mkArr (set (prod a b)) (set b) (λx. UP (hsnd (DOWN x)))
else null)"
definition pr1
where "pr1 a b = (if ide a ∧ ide b then
mkArr (set (prod a b)) (set a) (λx. UP (hfst (DOWN x)))
else null)"
definition tuple
where "tuple f g = mkArr (set (dom f)) (set (prod (cod f) (cod g)))
(λx. UP (hpair (DOWN (Fun f x)) (DOWN (Fun g x))))"
lemma ide_prod:
assumes "ide a" and "ide b"
shows "ide (prod a b)"
using assms prod_def hf_to_ide_mapsto ide_to_hf_mapsto by auto
lemma pr1_in_hom [intro]:
assumes "ide a" and "ide b"
shows "«pr1 a b : prod a b → a»"
proof
show 0: "arr (pr1 a b)"
proof -
have "set (prod a b) ⊆ Univ"
using assms ide_prod ide_char set_subset_Univ by blast
moreover have "set a ⊆ Univ"
using assms ide_char set_subset_Univ by blast
moreover have "(λx. UP (hfst (DOWN x))) ∈ set (prod a b) → set a"
proof (unfold prod_def)
show "(λx. UP (hfst (DOWN x))) ∈ set (hf_to_ide (ide_to_hf a * ide_to_hf b)) → set a"
proof
fix x
assume x: "x ∈ set (hf_to_ide (ide_to_hf a * ide_to_hf b))"
have "DOWN x ∈ hfset (ide_to_hf a * ide_to_hf b)"
using assms ide_char x
by (metis (no_types, lifting) prod_def DOWN_membI HF_hfset UNIV_I hmem_HF_iff
ide_prod ide_to_hf_hf_to_ide)
hence "hfst (DOWN x) ❙∈ ide_to_hf a"
by (metis HF_hfset finite_hfset hfst_conv hmem_HF_iff timesE)
thus "UP (hfst (DOWN x)) ∈ set a"
using UP_membI by simp
qed
qed
ultimately show ?thesis
unfolding pr1_def
using assms arr_mkArr ide_prod set_card by presburger
qed
show "dom (pr1 a b) = prod a b"
using assms 0 ide_char ide_prod dom_mkArr
by (metis (no_types, lifting) mkIde_set pr1_def)
show "cod (pr1 a b) = a"
using assms 0 ide_char ide_prod cod_mkArr
by (metis (no_types, lifting) mkIde_set pr1_def)
qed
lemma pr1_simps [simp]:
assumes "ide a" and "ide b"
shows "arr (pr1 a b)" and "dom (pr1 a b) = prod a b" and "cod (pr1 a b) = a"
using assms pr1_in_hom by blast+
lemma pr0_in_hom [intro]:
assumes "ide a" and "ide b"
shows "«pr0 a b : prod a b → b»"
proof
show 0: "arr (pr0 a b)"
proof -
have "set (prod a b) ⊆ Univ"
using assms ide_prod ide_char set_subset_Univ by blast
moreover have "set b ⊆ Univ"
using assms ide_char set_subset_Univ by blast
moreover have "(λx. UP (hsnd (DOWN x))) ∈ set (prod a b) → set b"
proof (unfold prod_def)
show "(λx. UP (hsnd (DOWN x))) ∈ set (hf_to_ide (ide_to_hf a * ide_to_hf b)) → set b"
proof
fix x
assume x: "x ∈ set (hf_to_ide (ide_to_hf a * ide_to_hf b))"
have "DOWN x ∈ hfset (ide_to_hf a * ide_to_hf b)"
using assms ide_char x
by (metis (no_types, lifting) prod_def DOWN_membI HF_hfset UNIV_I hmem_HF_iff
ide_prod ide_to_hf_hf_to_ide)
hence "hsnd (DOWN x) ❙∈ ide_to_hf b"
by (metis HF_hfset finite_hfset hsnd_conv hmem_HF_iff timesE)
thus "UP (hsnd (DOWN x)) ∈ set b"
using UP_membI by simp
qed
qed
ultimately show ?thesis
unfolding pr0_def
using assms arr_mkArr ide_prod set_card by presburger
qed
show "dom (pr0 a b) = prod a b"
using assms 0 ide_char ide_prod dom_mkArr
by (metis (no_types, lifting) mkIde_set pr0_def)
show "cod (pr0 a b) = b"
using assms 0 ide_char ide_prod cod_mkArr
by (metis (no_types, lifting) mkIde_set pr0_def)
qed
lemma pr0_simps [simp]:
assumes "ide a" and "ide b"
shows "arr (pr0 a b)" and "dom (pr0 a b) = prod a b" and "cod (pr0 a b) = b"
using assms pr0_in_hom by blast+
lemma UP_tuple_DOWN_membI:
assumes "span f g" and "x ∈ Dom f"
shows "UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩ ∈ set (prod (cod f) (cod g))"
proof -
have "Fun f x ∈ set (cod f)"
using assms Fun_mapsto by blast
moreover have "Fun g x ∈ set (cod g)"
using assms Fun_mapsto by auto
ultimately have "⟨DOWN (Fun f x), DOWN (Fun g x)⟩
❙∈ ide_to_hf (cod f) * ide_to_hf (cod g)"
using assms ide_cod by auto
moreover have "set (prod (cod f) (cod g)) ⊆ Univ"
using assms ide_char ide_cod set_subset_Univ ide_prod by presburger
ultimately show ?thesis
using prod_def UP_membI ide_to_hf_hf_to_ide by auto
qed
lemma tuple_in_hom [intro]:
assumes "span f g"
shows "«tuple f g : dom f → prod (cod f) (cod g)»"
proof
show 1: "arr (tuple f g)"
proof -
have "Dom f ⊆ Univ"
using assms set_subset_Univ ide_dom by blast
moreover have "set (prod (cod f) (cod g)) ⊆ Univ"
using assms ide_char ide_cod set_subset_Univ ide_prod by presburger
moreover have "(λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩)
∈ Dom f → set (prod (cod f) (cod g))"
using assms UP_tuple_DOWN_membI by simp
ultimately show ?thesis
using assms ide_prod tuple_def arr_mkArr set_card ide_dom ide_cod by simp
qed
show "dom (tuple f g) = dom f"
using assms 1 dom_mkArr ide_dom mkIde_set tuple_def by auto
show "cod (tuple f g) = prod (cod f) (cod g)"
using assms 1 cod_mkArr ide_cod mkIde_set tuple_def ide_prod by auto
qed
lemma tuple_simps [simp]:
assumes "span f g"
shows "arr (tuple f g)" and "dom (tuple f g) = dom f"
and "cod (tuple f g) = prod (cod f) (cod g)"
using assms tuple_in_hom by blast+
lemma Fun_pr1:
assumes "ide a" and "ide b"
shows "Fun (pr1 a b) = restrict (λx. UP (hfst (DOWN x))) (set (prod a b))"
using assms pr1_def Fun_mkArr arr_char pr1_simps(1) by presburger
lemma Fun_pr0:
assumes "ide a" and "ide b"
shows "Fun (pr0 a b) = restrict (λx. UP (hsnd (DOWN x))) (set (prod a b))"
using assms pr0_def Fun_mkArr arr_char pr0_simps(1) by presburger
lemma Fun_tuple:
assumes "span f g"
shows "Fun (tuple f g) = restrict (λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩) (Dom f)"
proof -
have "arr (tuple f g)"
using assms tuple_in_hom by blast
thus ?thesis
using assms tuple_def Fun_mkArr by simp
qed
lemma pr1_tuple:
assumes "span f g"
shows "comp (pr1 (cod f) (cod g)) (tuple f g) = f"
proof (intro arr_eqI)
have pr1: "«pr1 (cod f) (cod g) : prod (cod f) (cod g) → cod f»"
using assms ide_cod by blast
have tuple: "«tuple f g : dom f → prod (cod f) (cod g)»"
using assms by blast
show par: "par (comp (pr1 (cod f) (cod g)) (tuple f g)) f"
using assms pr1_in_hom tuple_in_hom
by (metis (no_types, lifting) comp_in_homI' ide_cod in_homE)
show "Fun (comp (pr1 (cod f) (cod g)) (tuple f g)) = Fun f"
proof -
have seq: "seq (pr1 (cod f) (cod g)) (tuple f g)"
using par by blast
have "Fun (comp (pr1 (cod f) (cod g)) (tuple f g)) =
restrict (Fun (pr1 (cod f) (cod g)) ∘ Fun (tuple f g)) (Dom (tuple f g))"
using pr1 tuple seq Fun_comp by simp
also have "... = restrict
(Fun (mkArr (set (prod (cod f) (cod g))) (Cod f)
(λx. UP (hfst (DOWN x)))) ∘
Fun (mkArr (Dom f) (set (prod (cod f) (cod g)))
(λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩)))
(Dom (tuple f g))"
unfolding pr1_def tuple_def
using assms ide_cod by presburger
also have
"... = restrict
(restrict (λx. UP (hfst (DOWN x))) (set (prod (cod f) (cod g))) o
restrict (λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩) (Dom f))
(Dom f)"
proof -
have "Fun (mkArr (set (prod (cod f) (cod g))) (Cod f) (λx. UP (hfst (DOWN x)))) =
restrict (λx. UP (hfst (DOWN x))) (set (prod (cod f) (cod g)))"
using assms Fun_mkArr ide_prod pr1
by (metis (no_types, lifting) arrI ide_cod pr1_def)
moreover have "Fun (mkArr (Dom f) (set (prod (cod f) (cod g)))
(λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩)) =
restrict (λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩) (Dom f)"
using assms Fun_mkArr ide_prod ide_cod tuple_def tuple arrI by simp
ultimately show ?thesis
using assms tuple_simps(2) by simp
qed
also have
"... = restrict
((λx. UP (hfst (DOWN x))) o (λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩))
(Dom f)"
using assms tuple tuple_def UP_tuple_DOWN_membI by auto
also have "... = restrict (Fun f) (Dom f)"
proof
fix x
have "restrict ((λx. UP (hfst (DOWN x))) o (λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩))
(Dom f) x =
restrict (λx. UP (DOWN (Fun f x))) (Dom f) x"
by simp
also have "... = restrict (Fun f) (Dom f) x"
proof (cases "x ∈ Dom f")
show "x ∉ Dom f ⟹ ?thesis" by simp
assume x: "x ∈ Dom f"
have "Fun f x ∈ Cod f"
using assms x Fun_mapsto arr_char by blast
moreover have "Cod f ⊆ Univ"
using assms pr1 ide_cod set_subset_Univ by simp
ultimately show ?thesis
using assms UP_DOWN Fun_mapsto by auto
qed
finally show "restrict ((λx. UP (hfst (DOWN x))) ∘
(λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩))
(Dom f) x =
restrict (Fun f) (Dom f) x"
by blast
qed
also have "... = Fun f"
using assms par Fun_mapsto Fun_mkArr mkArr_Fun
by (metis (no_types, lifting))
finally show ?thesis by blast
qed
qed
lemma pr0_tuple:
assumes "span f g"
shows "comp (pr0 (cod f) (cod g)) (tuple f g) = g"
proof (intro arr_eqI)
have pr0: "«pr0 (cod f) (cod g) : prod (cod f) (cod g) → cod g»"
using assms ide_cod by blast
have tuple: "«tuple f g : dom f → prod (cod f) (cod g)»"
using assms by blast
show par: "par (comp (pr0 (cod f) (cod g)) (tuple f g)) g"
using assms pr0_in_hom tuple_in_hom
by (metis (no_types, lifting) comp_in_homI' ide_cod in_homE)
show "Fun (comp (pr0 (cod f) (cod g)) (tuple f g)) = Fun g"
proof -
have seq: "seq (pr0 (cod f) (cod g)) (tuple f g)"
using par by blast
have "Fun (comp (pr0 (cod f) (cod g)) (tuple f g)) =
restrict (Fun (pr0 (cod f) (cod g)) ∘ Fun (tuple f g)) (Dom (tuple f g))"
using pr0 tuple seq Fun_comp by simp
also have
"... = restrict
(Fun (mkArr (set (prod (cod f) (cod g))) (Cod g)
(λx. UP (hsnd (DOWN x)))) ∘
Fun (mkArr (Dom f) (set (prod (cod f) (cod g)))
(λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩)))
(Dom (tuple f g))"
unfolding pr0_def tuple_def
using assms ide_cod by presburger
also have "... = restrict
(restrict (λx. UP (hsnd (DOWN x))) (set (prod (cod f) (cod g))) o
restrict (λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩) (Dom g))
(Dom g)"
proof -
have "Fun (mkArr (set (prod (cod f) (cod g))) (Cod g) (λx. UP (hsnd (DOWN x)))) =
restrict (λx. UP (hsnd (DOWN x))) (set (prod (cod f) (cod g)))"
using assms Fun_mkArr ide_prod arrI
by (metis (no_types, lifting) ide_cod pr0 pr0_def)
moreover have "Fun (mkArr (Dom f) (set (prod (cod f) (cod g)))
(λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩)) =
restrict (λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩) (Dom f)"
using assms Fun_mkArr ide_prod ide_cod tuple_def tuple arrI by simp
ultimately show ?thesis
using assms tuple_simps(2) by simp
qed
also have "... = restrict
((λx. UP (hsnd (DOWN x))) o (λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩))
(Dom g)"
using assms tuple tuple_def UP_tuple_DOWN_membI by auto
also have "... = restrict (Fun g) (Dom g)"
proof
fix x
have "restrict ((λx. UP (hsnd (DOWN x)))
o (λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩))
(Dom g) x =
restrict (λx. UP (DOWN (Fun g x))) (Dom g) x"
by simp
also have "... = restrict (Fun g) (Dom g) x"
proof (cases "x ∈ Dom g")
show "x ∉ Dom g ⟹ ?thesis" by simp
assume x: "x ∈ Dom g"
have "Fun g x ∈ Cod g"
using assms x Fun_mapsto arr_char by blast
moreover have "Cod g ⊆ Univ"
using assms pr0 ide_cod set_subset_Univ by simp
ultimately show ?thesis
using assms UP_DOWN Fun_mapsto by auto
qed
finally show "restrict ((λx. UP (hsnd (DOWN x))) ∘
(λx. UP ⟨DOWN (Fun f x), DOWN (Fun g x)⟩))
(Dom g) x =
restrict (Fun g) (Dom g) x"
by blast
qed
also have "... = Fun g"
using assms par Fun_mapsto Fun_mkArr mkArr_Fun
by (metis (no_types, lifting))
finally show ?thesis by blast
qed
qed
lemma tuple_pr:
assumes "ide a" and "ide b" and "«h : dom h → prod a b»"
shows "tuple (comp (pr1 a b) h) (comp (pr0 a b) h) = h"
proof (intro arr_eqI)
have pr0: "«pr0 a b : prod a b → b»"
using assms pr0_in_hom ide_cod by blast
have pr1: "«pr1 a b : prod a b → a»"
using assms pr1_in_hom ide_cod by blast
have tuple: "«tuple (comp (pr1 a b) h) (comp (pr0 a b) h) : dom h → prod a b»"
using assms pr0 pr1
by (metis (no_types, lifting) cod_comp dom_comp pr0_simps(3) pr1_simps(3)
seqI' tuple_in_hom)
show par: "par (tuple (comp (pr1 a b) h) (comp (pr0 a b) h)) h"
using assms tuple by (metis (no_types, lifting) in_homE)
show "Fun (tuple (comp (pr1 a b) h) (comp (pr0 a b) h)) = Fun h"
proof -
have 1: "Fun (comp (pr1 a b) h) =
restrict (restrict (λx. UP (hfst (DOWN x))) (set (prod a b)) ∘ Fun h) (Dom h)"
using assms pr1 Fun_comp Fun_pr1 seqI' by auto
have 2: "Fun (comp (pr0 a b) h) =
restrict (restrict (λx. UP (hsnd (DOWN x))) (set (prod a b)) ∘ Fun h) (Dom h)"
using assms pr0 Fun_comp Fun_pr0 seqI' by auto
have "Fun (tuple (comp (pr1 a b) h) (comp (pr0 a b) h)) =
restrict (λx. UP ⟨DOWN (restrict
(restrict (λx. UP (hfst (DOWN x))) (set (prod a b)) ∘ Fun h)
(Dom h) x),
DOWN (restrict
(restrict (λx. UP (hsnd (DOWN x))) (set (prod a b)) ∘ Fun h)
(Dom h) x)⟩)
(Dom h)"
proof -
have "Dom (comp (pr1 a b) h) = Dom h"
using assms pr1_in_hom
by (metis (no_types, lifting) in_homE dom_comp seqI)
moreover have "arr (mkArr (Dom (comp (pr1 a b) h))
(set (prod (cod (comp (pr1 a b) h)) (cod (comp (pr0 a b) h))))
(λx. UP ⟨DOWN (Fun (comp (pr1 a b) h) x),
DOWN (Fun (comp (pr0 a b) h) x)⟩))"
using tuple unfolding tuple_def by blast
ultimately show ?thesis
using 1 2 tuple tuple_def
Fun_mkArr [of "Dom (comp (pr1 a b) h)"
"set (prod (cod (comp (pr1 a b) h))
(cod (comp (pr0 a b) h)))"
"λx. UP ⟨DOWN (Fun (comp (pr1 a b) h) x),
DOWN (Fun (comp (pr0 a b) h) x)⟩"]
by simp
qed
also have "... = Fun h"
proof
let ?f = "..."
fix x
show "?f x = Fun h x"
proof -
have "x ∉ Dom h ⟹ ?f x = Fun h x"
proof -
assume x: "x ∉ Dom h"
have "restrict ?f (Dom h) x = undefined"
using assms x restrict_apply by auto
also have "... = Fun h x"
proof -
have "arr h"
using assms by blast
thus ?thesis
using assms x Fun_mapsto [of h] extensional_arb [of "Fun h" "Dom h" x]
by simp
qed
finally show ?thesis by auto
qed
moreover have "x ∈ Dom h ⟹ ?f x = Fun h x"
proof -
assume x: "x ∈ Dom h"
have 1: "Fun h x ∈ set (prod a b)"
proof -
have "Fun h x ∈ Cod h"
using assms x Fun_mapsto [of h] by blast
moreover have "Cod h = set (prod a b)"
using assms ide_prod
by (metis (no_types, lifting) in_homE)
ultimately show ?thesis by fast
qed
have "?f x = UP ⟨hfst (DOWN (Fun h x)), hsnd (DOWN (Fun h x))⟩"
using x 1 by simp
also have "... = UP (DOWN (Fun h x))"
proof -
have "DOWN (Fun h x) ❙∈ ide_to_hf a * ide_to_hf b"
using assms x 1 par
by (metis (no_types, lifting) prod_def DOWN_membI UNIV_I ide_prod
ide_to_hf_hf_to_ide)
thus ?thesis
using x is_hpair_def by auto
qed
also have "... = Fun h x"
using assms 1 ide_prod set_subset_Univ UP_DOWN
by (meson subsetD)
finally show ?thesis by blast
qed
ultimately show ?thesis by blast
qed
qed
finally show ?thesis by blast
qed
qed
interpretation HF': elementary_category_with_binary_products comp pr0 pr1
proof
show "⋀a b. ⟦ide a; ide b⟧ ⟹ span (pr1 a b) (pr0 a b)"
using pr0_simps(1) pr0_simps(2) pr1_simps(1) pr1_simps(2) by auto
show "⋀a b. ⟦ide a; ide b⟧ ⟹ cod (pr0 a b) = b"
using pr0_simps(1-3) by blast
show "⋀a b. ⟦ide a; ide b⟧ ⟹ cod (pr1 a b) = a"
using pr1_simps(1-3) by blast
show "⋀f g. span f g ⟹
∃!l. comp (pr1 (cod f) (cod g)) l = f ∧ comp (pr0 (cod f) (cod g)) l = g"
proof
fix f g
assume fg: "span f g"
show "comp (pr1 (cod f) (cod g)) (tuple f g) = f ∧
comp (pr0 (cod f) (cod g)) (tuple f g) = g"
using fg pr0_simps pr1_simps tuple_simps pr0_tuple pr1_tuple by presburger
show "⋀l. ⟦comp (pr1 (cod f) (cod g)) l = f ∧ comp (pr0 (cod f) (cod g)) l = g⟧
⟹ l = tuple f g "
proof -
fix l
assume l: "comp (pr1 (cod f) (cod g)) l = f ∧ comp (pr0 (cod f) (cod g)) l = g"
show "l = tuple f g"
using fg l tuple_pr
by (metis (no_types, lifting) arr_iff_in_hom ide_cod seqE pr0_simps(2))
qed
qed
show "⋀a b. ¬ (ide a ∧ ide b) ⟹ pr0 a b = null"
using pr0_def by auto
show "⋀a b. ¬ (ide a ∧ ide b) ⟹ pr1 a b = null"
using pr1_def by auto
qed
text‹
For reasons of economy of locale parameters, the notion ‹prod› is a defined notion
of the @{locale elementary_category_with_binary_products} locale.
However, we need to be able to relate this notion to that of cartesian product of
hereditarily finite sets, which we have already used to give a definition of ‹prod›.
The locale assumptions for @{locale elementary_cartesian_closed_category} refer
specifically to ‹HF'.prod›, even though in the end the notion itself does not depend
on that choice. To be able to show that the locale assumptions of
@{locale elementary_cartesian_closed_category} are satisfied, we need to use a choice
of products that we can relate to the cartesian product of hereditarily
finite sets. We therefore need to show that our previously defined ‹prod› coincides
(on objects) with the one defined in the @{locale elementary_category_with_binary_products} locale;
\emph{i.e.}~‹HF'.prod›. Note that the latter is defined for all arrows,
not just identity arrows, so we need to use that for the subsequent definitions and proofs.
›
lemma prod_ide_eq:
assumes "ide a" and "ide b"
shows "prod a b = HF'.prod a b"
using assms prod_def HF'.pr_simps(2) HF'.prod_def pr0_simps(2) by presburger
lemma tuple_span_eq:
assumes "span f g"
shows "tuple f g = HF'.tuple f g"
using assms tuple_def HF'.tuple_def
by (metis (no_types, lifting) HF'.tuple_eqI pr0_tuple pr1_tuple)
section "Exponentials"
text‹
We now turn our attention to exponentials.
›
definition exp
where "exp b c = hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c))"
definition eval
where "eval b c = mkArr (set (HF'.prod (exp b c) b)) (set c)
(λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))"
definition Λ
where "Λ a b c f = mkArr (set a) (set (exp b c))
(λx. UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
(arr_to_hfun f))
(DOWN x)))"
lemma ide_exp:
assumes "ide b" and "ide c"
shows "ide (exp b c)"
using assms exp_def hf_to_ide_mapsto ide_to_hf_mapsto by auto
lemma hfset_ide_to_hf:
assumes "ide a"
shows "hfset (ide_to_hf a) = DOWN ` set a"
using assms ide_to_hf_def ide_implies_finite_set(1) by auto
lemma eval_in_hom [intro]:
assumes "ide b" and "ide c"
shows "in_hom (eval b c) (HF'.prod (exp b c) b) c"
proof
show 1: "arr (eval b c)"
proof (unfold eval_def arr_mkArr, intro conjI)
show "set (HF'.prod (exp b c) b) ⊆ Univ"
using assms ide_char HF'.ide_prod ide_exp set_subset_Univ by simp
show "set c ⊆ Univ"
using assms ide_char set_subset_Univ by simp
show "(λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
∈ set (HF'.prod (exp b c) b) → set c"
proof
fix x
assume "x ∈ set (HF'.prod (exp b c) b)"
hence x: "x ∈ set (prod (exp b c) b)"
using assms prod_ide_eq ide_exp by auto
show "UP (happ (hfst (DOWN x)) (hsnd (DOWN x))) ∈ set c"
proof (intro UP_membI)
show "happ (hfst (DOWN x)) (hsnd (DOWN x)) ❙∈ ide_to_hf c"
proof -
have 1: "DOWN x ❙∈ ide_to_hf (exp b c) * ide_to_hf b"
proof -
have "DOWN x ❙∈ ide_to_hf (prod (exp b c) b)"
using assms x DOWN_membI ide_prod ide_exp by simp
thus ?thesis
using assms x prod_def ide_to_hf_hf_to_ide by auto
qed
have "hfst (DOWN x) ❙∈ hexp (ide_to_hf b) (ide_to_hf c)"
using assms 1 x exp_def ide_to_hf_hf_to_ide by auto
moreover have "hsnd (DOWN x) ❙∈ ide_to_hf b"
using assms 1 by auto
ultimately show ?thesis
using happ_mapsto [of "hfst (DOWN x)" "ide_to_hf b" "ide_to_hf c"
"hsnd (DOWN x)"]
by simp
qed
qed
qed
show "|set (HF'.prod (exp b c) b)| <o natLeq"
using assms ide_exp HF'.ide_prod set_card by auto
show "|set c| <o natLeq"
using assms set_card by auto
qed
show "dom (eval b c) = HF'.prod (exp b c) b"
using assms 1 ide_char HF'.ide_prod ide_exp dom_mkArr eval_def
by (metis (no_types, lifting) mkIde_set)
show "cod (eval b c) = c"
using assms 1 ide_char cod_mkArr eval_def
by (metis (no_types, lifting) mkIde_set)
qed
lemma eval_simps [simp]:
assumes "ide b" and "ide c"
shows "arr (eval b c)"
and "dom (eval b c) = HF'.prod (exp b c) b"
and "cod (eval b c) = c"
using assms eval_in_hom by blast+
lemma hlam_arr_to_hfun_in_hexp:
assumes "ide a" and "ide b" and "ide c"
and "in_hom f (prod a b) c"
shows "hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c) (arr_to_hfun f)
❙∈ hexp (ide_to_hf a) (ide_to_hf (exp b c))"
using assms hfun_in_hexp hfun_hlam
by (metis (no_types, lifting) prod_def HCollect_iff in_homE UNIV_I
arr_to_hfun_in_hexp exp_def hexp_def ide_to_hf_hf_to_ide)
lemma lam_in_hom [intro]:
assumes "ide a" and "ide b" and "ide c"
and "in_hom f (prod a b) c"
shows "in_hom (Λ a b c f) a (exp b c)"
proof
show 1: "arr (Λ a b c f)"
proof (unfold Λ_def arr_mkArr, intro conjI)
show "set a ⊆ Univ"
using assms(1) set_subset_Univ ide_char by blast
show "set (exp b c) ⊆ Univ"
using assms(2-3) set_subset_Univ ide_exp ide_char by simp
show "|set a| <o natLeq"
using assms(1) set_card by simp
show "|set (exp b c)| <o natLeq"
using assms(2-3) set_card ide_exp by auto
show "(λx. UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c) (arr_to_hfun f))
(DOWN x)))
∈ set a → set (exp b c)"
proof
fix x
assume x: "x ∈ set a"
show "UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c) (arr_to_hfun f))
(DOWN x))
∈ set (exp b c)"
using assms x hlam_arr_to_hfun_in_hexp ide_to_hf_def DOWN_membI happ_mapsto
UP_membI
by meson
qed
qed
show "dom (Λ a b c f) = a"
using assms(1) 1 Λ_def ide_char dom_mkArr mkIde_set by auto
show "cod (Λ a b c f) = exp b c"
using assms(2-3) 1 Λ_def cod_mkArr ide_exp mkIde_set by auto
qed
lemma lam_simps [simp]:
assumes "ide a" and "ide b" and "ide c"
and "in_hom f (prod a b) c"
shows "arr (Λ a b c f)"
and "dom (Λ a b c f) = a"
and "cod (Λ a b c f) = exp b c"
using assms lam_in_hom by blast+
lemma Fun_lam:
assumes "ide a" and "ide b" and "ide c"
and "in_hom f (prod a b) c"
shows "Fun (Λ a b c f) =
restrict (λx. UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c) (arr_to_hfun f))
(DOWN x)))
(set a)"
using assms arr_char lam_simps(1) Λ_def Fun_mkArr by simp
lemma Fun_eval:
assumes "ide b" and "ide c"
shows "Fun (eval b c) = restrict (λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
(set (HF'.prod (exp b c) b))"
using assms arr_char eval_simps(1) eval_def Fun_mkArr by force
lemma Fun_prod:
assumes "arr f" and "arr g" and "x ∈ set (prod (dom f) (dom g))"
shows "Fun (HF'.prod f g) x = UP ⟨DOWN (Fun f (UP (hfst (DOWN x)))),
DOWN (Fun g (UP (hsnd (DOWN x))))⟩"
proof -
have 1: "span (comp f (pr1 (dom f) (dom g))) (comp g (pr0 (dom f) (dom g)))"
using assms
by (metis (no_types, lifting) HF'.prod_def HF'.prod_simps(1) HF'.tuple_ext not_arr_null)
have 2: "Dom (comp f (pr1 (dom f) (dom g))) = set (prod (dom f) (dom g))"
using assms
by (metis (mono_tags, lifting) 1 dom_comp ide_dom pr0_simps(2))
have 3: "Dom (comp g (pr0 (dom f) (dom g))) = set (prod (dom f) (dom g))"
using assms 1 2 by force
have "Fun (HF'.prod f g) x =
Fun (HF'.tuple (comp f (pr1 (dom f) (dom g))) (comp g (pr0 (dom f) (dom g)))) x"
using assms(3) HF'.prod_def by simp
also have "... = restrict (λx. UP ⟨DOWN (Fun (comp f (pr1 (dom f) (dom g))) x),
DOWN (Fun (comp g (pr0 (dom f) (dom g))) x)⟩)
(Dom (comp f (pr1 (dom f) (dom g))))
x"
using assms 1 tuple_span_eq Fun_tuple by simp
also have "... = UP ⟨DOWN (Fun (comp f (pr1 (dom f) (dom g))) x),
DOWN (Fun (comp g (pr0 (dom f) (dom g))) x)⟩"
using assms(3) 2 by simp
also have "... = UP ⟨DOWN (Fun f (UP (hfst (DOWN x)))),
DOWN (Fun g (UP (hsnd (DOWN x))))⟩"
proof -
have "Fun (comp f (pr1 (dom f) (dom g))) x = Fun f (UP (hfst (DOWN x)))"
proof -
have 4: "seq f (pr1 (dom f) (dom g))"
using assms 1 by blast
have "Fun (comp f (pr1 (dom f) (dom g))) x =
restrict (Fun f ∘ Fun (pr1 (dom f) (dom g))) (Dom (pr1 (dom f) (dom g))) x"
using assms 1 Fun_comp [of f "pr1 (dom f) (dom g)"]
by (metis (no_types, lifting))
also have "... = (Fun f ∘ Fun (pr1 (dom f) (dom g))) x"
proof -
have "x ∈ Dom (pr1 (dom f) (dom g))"
using assms 1 2 4
by (metis (no_types, lifting) dom_comp)
thus ?thesis by simp
qed
also have "... = Fun f (Fun (pr1 (dom f) (dom g)) x)"
by simp
also have "... = Fun f (UP (hfst (DOWN x)))"
using assms 1 Fun_pr1 [of "dom f" "dom g"] ide_dom by simp
finally show ?thesis by blast
qed
moreover
have "Fun (comp g (pr0 (dom f) (dom g))) x = Fun g (UP (hsnd (DOWN x)))"
proof -
have 4: "seq g (pr0 (dom f) (dom g))"
using assms 1 by blast
have "Fun (comp g (pr0 (dom f) (dom g))) x =
restrict (Fun g ∘ Fun (pr0 (dom f) (dom g))) (Dom (pr0 (dom f) (dom g))) x"
using assms 1 Fun_comp [of g "pr0 (dom f) (dom g)"]
by (metis (no_types, lifting))
also have "... = (Fun g ∘ Fun (pr0 (dom f) (dom g))) x"
proof -
have "x ∈ Dom (pr0 (dom f) (dom g))"
using assms 1 2 4
by (metis (no_types, lifting) dom_comp)
thus ?thesis by simp
qed
also have "... = Fun g (Fun (pr0 (dom f) (dom g)) x)"
by simp
also have "... = Fun g (UP (hsnd (DOWN x)))"
using assms 1 Fun_pr0 [of "dom f" "dom g"] ide_dom by simp
finally show ?thesis by blast
qed
ultimately show ?thesis by simp
qed
finally show ?thesis by simp
qed
lemma prod_in_terms_of_tuple:
assumes "arr f" and "arr g"
shows "HF'.prod f g =
tuple (comp f (pr1 (dom f) (dom g))) (comp g (pr0 (dom f) (dom g)))"
using assms HF'.prod_def tuple_span_eq
by (metis (no_types, lifting) HF'.prod_simps(1) HF'.tuple_ext not_arr_null)
lemma eval_prod_lam:
assumes "ide a" and "ide b" and "ide c"
and "in_hom g (prod a b) c"
shows "comp (eval b c) (HF'.prod (Λ a b c g) b) = g"
proof -
have ide_dom_lam: "ide (dom (Λ a b c g))"
using assms lam_in_hom [of a b c g] ide_dom by blast
have ide_dom_b: "ide (dom b)"
using assms ide_dom ideD(1) by blast
define Λ_pr1 where "Λ_pr1 = comp (Λ a b c g) (pr1 (dom (Λ a b c g)) (dom b))"
define b_pr0 where "b_pr0 = comp b (pr0 (dom (Λ a b c g)) (dom b))"
have lam_pr1: "in_hom Λ_pr1 (prod a b) (exp b c)"
proof (unfold Λ_pr1_def, intro comp_in_homI)
show "in_hom (pr1 (dom (Λ a b c g)) (dom b)) (prod a b) a"
using assms ide_dom_lam ide_dom_b ideD(2) lam_simps(2) pr1_in_hom by auto
show "in_hom (Λ a b c g) a (exp b c)"
using assms lam_in_hom by simp
qed
have b_pr0: "in_hom b_pr0 (prod a b) b"
using assms b_pr0_def
by (metis (no_types, lifting) HF'.arr_pr0_iff HF'.cod_pr0 comp_in_homI'
ideD(1-3) lam_simps(2) pr0_simps(2))
have 1: "span Λ_pr1 b_pr0"
using lam_pr1 b_pr0
by (metis (no_types, lifting) in_homE)
have tuple: "in_hom (tuple Λ_pr1 b_pr0) (prod a b) (prod (exp b c) b)"
using 1 lam_pr1 b_pr0 tuple_in_hom [of Λ_pr1 b_pr0]
by (metis (mono_tags, lifting) in_homE)
define Λ_pr1' where "Λ_pr1' = comp (Λ a b c g) (pr1 a b)"
define b_pr0' where "b_pr0' = pr0 a b"
have lam_pr1_eq: "Λ_pr1 = Λ_pr1'"
using assms Λ_pr1_def Λ_pr1'_def ideD(2) lam_simps(2) by auto
have b_pr0_eq: "b_pr0 = b_pr0'"
using assms b_pr0_def b_pr0'_def b_pr0 comp_ide_arr
by (metis (no_types, lifting) ideD(2) in_homE lam_simps(2))
have Fun_pr0: "Fun (pr0 a b) = restrict (λx. UP (hsnd (DOWN x))) (set (prod a b))"
using assms Fun_pr0 by simp
have Fun_lam_pr1: "Fun Λ_pr1 =
restrict (Fun (Λ a b c g) o
restrict (λx. UP (hfst (DOWN x))) (set (prod a b)))
(set (prod a b))"
using assms 1 Fun_comp Fun_pr1 lam_pr1_eq Λ_pr1'_def
by (metis (no_types, lifting) pr1_simps(2))
have "comp (eval b c) (HF'.prod (Λ a b c g) b) = comp (eval b c) (tuple Λ_pr1 b_pr0)"
using assms Λ_pr1_def b_pr0_def 1 prod_in_terms_of_tuple ideD(1) lam_simps(1)
by presburger
also have 5: "... = comp (eval b c) (tuple Λ_pr1' b_pr0')"
using lam_pr1_eq b_pr0_eq by simp
also have "... = g"
proof (intro arr_eqI)
have 2: "arr (comp (eval b c) (tuple Λ_pr1 b_pr0))"
using assms tuple arr_char
by (metis (no_types, lifting) in_homE seqI eval_simps(1-2) ide_exp prod_ide_eq)
have 3: "arr g"
using assms by blast
have tuple': "in_hom (tuple Λ_pr1' b_pr0') (prod a b) (prod (exp b c) b)"
using tuple lam_pr1_eq b_pr0_eq by blast
have 4: "Dom g = set (prod a b)"
using assms
by (metis (no_types, lifting) in_homE)
show par: "par (comp (eval b c) (tuple Λ_pr1' b_pr0')) g"
using assms tuple' 2 3 5
by (metis (no_types, lifting) cod_comp dom_comp in_homE eval_simps(3))
show "Fun (comp (eval b c) (tuple Λ_pr1' b_pr0')) = Fun g"
proof
fix x
have "x ∉ set (prod a b) ⟹ Fun (comp (eval b c) (tuple Λ_pr1' b_pr0')) x = Fun g x"
proof -
have 5: "Fun g ∈ extensional (Dom g)"
using assms 3 Fun_mapsto by simp
moreover have "Fun (comp (eval b c) (tuple Λ_pr1' b_pr0')) ∈ extensional (Dom g)"
using 5 par Fun_mapsto by (metis (no_types, lifting) Int_iff)
ultimately show "x ∉ set (prod a b) ⟹
Fun (comp (eval b c) (tuple Λ_pr1' b_pr0')) x = Fun g x"
using 4 extensional_arb [of "Fun g" "Dom g" x]
extensional_arb [of "Fun (comp (eval b c) (tuple Λ_pr1' b_pr0'))" "Dom g" x]
by force
qed
moreover have "x ∈ set (prod a b) ⟹
Fun (comp (eval b c) (tuple Λ_pr1' b_pr0')) x = Fun g x"
proof -
assume x: "x ∈ set (prod a b)"
have 6: "Dom (tuple Λ_pr1' b_pr0') = set (prod a b)"
using assms 4 tuple' par
by (metis (no_types, lifting) in_homE)
have "Fun (comp (eval b c) (tuple Λ_pr1' b_pr0')) x =
Fun (eval b c) (Fun (tuple Λ_pr1' b_pr0') x)"
proof -
have "Fun (comp (eval b c) (tuple Λ_pr1' b_pr0')) x =
(Fun (eval b c) ∘ Fun (tuple Λ_pr1' b_pr0')) x"
using assms par x 6 Fun_comp [of "eval b c" "tuple Λ_pr1' b_pr0'"] by auto
also have "... = Fun (eval b c) (Fun (tuple Λ_pr1' b_pr0') x)"
by simp
finally show ?thesis by blast
qed
also have "... = restrict (λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
(set (HF'.prod (exp b c) b))
(Fun (tuple Λ_pr1' b_pr0') x)"
using assms Fun_eval by simp
also have "... = (λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
(Fun (tuple Λ_pr1' b_pr0') x)"
proof -
have "Fun (tuple Λ_pr1' b_pr0') x ∈ set (HF'.prod (exp b c) b)"
proof -
have "x ∈ Dom (tuple Λ_pr1' b_pr0')"
using x 6 by blast
moreover have "Cod (tuple Λ_pr1' b_pr0') = set (HF'.prod (exp b c) b)"
by (metis (no_types, lifting) in_homE assms(2-3) ide_exp
prod_ide_eq tuple')
moreover have "arr (tuple Λ_pr1' b_pr0')"
using tuple' by blast
ultimately show ?thesis
using tuple' Fun_mapsto [of "tuple Λ_pr1' b_pr0'"] by auto
qed
thus ?thesis
using restrict_apply by simp
qed
also have "... = (λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
(UP ⟨DOWN (Fun Λ_pr1' x), DOWN (Fun b_pr0' x)⟩)"
proof -
have 7: "Dom Λ_pr1' = set (prod a b)"
using assms
by (metis (no_types, lifting) 1 comp_ide_arr ideD(2)
b_pr0_def lam_pr1_eq lam_simps(2) pr0_simps(2))
moreover have "span Λ_pr1' b_pr0'"
using assms 1 b_pr0_eq lam_pr1_eq by auto
moreover have "x ∈ Dom Λ_pr1'"
using x 7 by simp
ultimately have "Fun (tuple Λ_pr1' b_pr0') x =
UP ⟨DOWN (Fun Λ_pr1' x), DOWN (Fun b_pr0' x)⟩"
using assms x restrict_apply Fun_tuple by simp
thus ?thesis by simp
qed
also have "... = UP (happ (DOWN (Fun Λ_pr1' x)) (DOWN (Fun b_pr0' x)))"
using assms by simp
also have "... = UP (happ (DOWN (UP (happ (hlam (ide_to_hf a) (ide_to_hf b)
(ide_to_hf c) (arr_to_hfun g))
(hfst (DOWN x)))))
(DOWN (UP (hsnd (DOWN x)))))"
proof -
have "Fun b_pr0' x = UP (hsnd (DOWN x))"
using assms x Fun_pr0 b_pr0'_def by simp
moreover have "Fun Λ_pr1' x =
UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
(arr_to_hfun g))
(hfst (DOWN x)))"
proof -
have "Fun Λ_pr1' x =
restrict (Fun (Λ a b c g) o Fun (pr1 a b)) (Dom (pr1 a b)) x"
using assms x Fun_pr1 Fun_comp lam_pr1_eq Fun_lam_pr1 pr1_simps(1-2)
by presburger
also have "... = Fun (Λ a b c g) (Fun (pr1 a b) x)"
using assms x restrict_apply Fun_lam_pr1 Fun_pr1 calculation lam_pr1_eq
by auto
also have "... = restrict (λx. UP (happ (hlam (ide_to_hf a) (ide_to_hf b)
(ide_to_hf c) (arr_to_hfun g))
(DOWN x)))
(set a)
(Fun (pr1 a b) x)"
using assms x Fun_lam by simp
also have "... = UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
(arr_to_hfun g))
(DOWN (Fun (pr1 a b) x)))"
proof -
have "Fun (pr1 a b) x ∈ set a"
proof -
have "x ∈ Dom (pr1 a b)"
using assms x pr1_simps(1-2) by auto
moreover have "Cod (pr1 a b) = set a"
using assms HF'.cod_pr1 pr1_simps(1) by auto
moreover have "arr (pr1 a b)"
using assms arr_char by blast
ultimately show ?thesis
using Fun_mapsto [of "pr1 a b"] by auto
qed
thus ?thesis
using restrict_apply by simp
qed
also have "... = UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
(arr_to_hfun g))
(hfst (DOWN x)))"
using assms x Fun_pr1 Fun_lam [of a b c g] by simp
finally show ?thesis by simp
qed
ultimately show ?thesis by simp
qed
also have "... = UP (happ (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
(arr_to_hfun g))
(hfst (DOWN x)))
(hsnd (DOWN x)))"
by simp
also have "... = UP (happ (arr_to_hfun g) (DOWN x))"
using assms x happ_hlam
by (metis (no_types, lifting) prod_def DOWN_membI HCollect_iff ide_dom
in_homE UNIV_I arr_to_hfun_in_hexp hexp_def hfst_conv hsnd_conv
ide_to_hf_hf_to_ide timesE)
also have "... = Fun g x"
using assms x 3 4 Fun_char [of g] restrict_apply [of "Fun g" "Dom g" x]
by simp
finally show ?thesis by simp
qed
ultimately show "Fun (comp (eval b c) (tuple Λ_pr1' b_pr0')) x = Fun g x"
by auto
qed
qed
finally show ?thesis by simp
qed
lemma lam_eval_prod:
assumes "ide a" and "ide b" and "ide c"
and "in_hom h a (exp b c)"
shows "Λ a b c (comp (eval b c) (HF'.prod h b)) = h"
proof (intro arr_eqI)
have 0: "in_hom (comp (eval b c) (HF'.prod h b)) (prod a b) c"
proof
show "in_hom (HF'.prod h b) (prod a b) (HF'.prod (exp b c) b)"
proof
show 1: "arr (HF'.prod h b)"
using assms HF'.prod_in_hom'
by (metis (no_types, lifting) ideD(1) in_homE)
show "dom (HF'.prod h b) = prod a b"
using assms 1
by (metis (no_types, lifting) HF'.prod_simps(2) ideD(1-2) in_homE prod_ide_eq)
show "cod (HF'.prod h b) = HF'.prod (exp b c) b"
using assms 1
by (metis (no_types, lifting) HF'.prod_simps(3) ideD(1,3) in_homE)
qed
show "in_hom (eval b c) (HF'.prod (exp b c) b) c"
using assms by blast
qed
have 1: "in_hom (Λ a b c (comp (eval b c) (HF'.prod h b))) a (exp b c)"
using assms 0 by blast
have 2: "Fun (comp (eval b c) (HF'.prod h b)) =
restrict (Fun (eval b c) ∘ Fun (HF'.prod h b))
(set (HF'.prod a b))"
proof -
have "seq (eval b c) (HF'.prod h b)"
using assms 1
by (metis (no_types, lifting) 0 in_homE)
moreover have "Dom (HF'.prod h b) = set (HF'.prod a b)"
using assms
by (metis (no_types, lifting) HF'.prod_simps(2) ideD(1-2) in_homE)
ultimately show ?thesis
using assms Fun_comp [of "eval b c" "HF'.prod h b"] by simp
qed
show par: "par (Λ a b c (comp (eval b c) (HF'.prod h b))) h"
using assms 1
by (metis (no_types, lifting) in_homE)
show "Fun (Λ a b c (comp (eval b c) (HF'.prod h b))) = Fun h"
proof
fix x
show "Fun (Λ a b c (comp (eval b c) (HF'.prod h b))) x = Fun h x"
proof -
have "x ∉ set a ⟹ ?thesis"
using assms 1 Fun_mapsto
extensional_arb [of "Fun h" "set a" x]
extensional_arb [of "Fun (Λ a b c (comp (eval b c) (HF'.prod h b)))"
"set a" x]
by (metis (no_types, lifting) 0 Int_iff lam_simps(2) par)
moreover have "x ∈ set a ⟹ ?thesis"
proof -
assume x: "x ∈ set a"
have 3: "dom (comp (eval b c) (HF'.prod h b)) = HF'.prod a b"
using assms 0 in_homE prod_ide_eq by auto
have 4: "cod (comp (eval b c) (HF'.prod h b)) = c"
using assms 0 by blast
have 5: "dom (comp (eval b c) (HF'.prod h b)) = HF'.prod a b"
using assms 3
by (metis (mono_tags, lifting))
have 6: "cod (comp (eval b c) (HF'.prod h b)) = c"
using assms 4 by (metis (no_types, lifting))
have "arr_to_hfun (comp (eval b c) (HF'.prod h b)) =
⦃xy ❙∈ ide_to_hf (HF'.prod a b) * ide_to_hf c.
hsnd xy = DOWN (Fun (comp (eval b c) (HF'.prod h b)) (UP (hfst xy)))⦄"
unfolding arr_to_hfun_def
using 2 5 6 by metis
have "Fun (Λ a b c (comp (eval b c) (HF'.prod h b))) x =
UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
(arr_to_hfun (comp (eval b c) (HF'.prod h b))))
(DOWN x))"
using assms 0 x Fun_lam by auto
also have "... = UP ⦃yz ❙∈ ide_to_hf b * ide_to_hf c.
⟨⟨DOWN x, hfst yz⟩, hsnd yz⟩
❙∈ arr_to_hfun (comp (eval b c) (HF'.prod h b))⦄"
proof -
have "seq (eval b c) (HF'.prod h b)"
using assms 0 by blast
moreover have "ide_to_hf (dom (comp (eval b c) (HF'.prod h b))) =
ide_to_hf a * ide_to_hf b"
using assms 1 3
by (metis (no_types, lifting) prod_def UNIV_I ide_to_hf_hf_to_ide prod_ide_eq)
moreover have "ide_to_hf (cod (comp (eval b c) (HF'.prod h b))) = ide_to_hf c"
using assms 2 4 by auto
ultimately show ?thesis
using assms 0 x happ_hlam(3) DOWN_membI
hfun_arr_to_hfun [of "comp (eval b c) (HF'.prod h b)"]
by simp
qed
also have "... = UP ⦃yz ❙∈ ide_to_hf b * ide_to_hf c.
hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
(UP ⟨DOWN x, hfst yz⟩))⦄"
proof -
have "⦃yz ❙∈ ide_to_hf b * ide_to_hf c.
⟨⟨DOWN x, hfst yz⟩, hsnd yz⟩
❙∈ arr_to_hfun (comp (eval b c) (HF'.prod h b))⦄ =
⦃yz ❙∈ ide_to_hf b * ide_to_hf c.
hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
(UP ⟨DOWN x, hfst yz⟩))⦄"
proof
fix yz
show "yz ❙∈ ⦃yz ❙∈ ide_to_hf b * ide_to_hf c.
⟨⟨DOWN x, hfst yz⟩, hsnd yz⟩
❙∈ arr_to_hfun (comp (eval b c) (HF'.prod h b))⦄ ⟷
yz ❙∈ ⦃yz ❙∈ ide_to_hf b * ide_to_hf c.
hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
(UP ⟨DOWN x, hfst yz⟩))⦄"
proof -
have "yz ❙∈ ide_to_hf b * ide_to_hf c ⟹
⟨⟨DOWN x, hfst yz⟩, hsnd yz⟩ ❙∈ arr_to_hfun (comp (eval b c) (HF'.prod h b))
⟷ hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
(UP ⟨DOWN x, hfst yz⟩))"
proof -
assume yz: "yz ❙∈ ide_to_hf b * ide_to_hf c"
have "⟨⟨DOWN x, hfst yz⟩, hsnd yz⟩
❙∈ arr_to_hfun (comp (eval b c) (HF'.prod h b))
⟷
⟨⟨DOWN x, hfst yz⟩, hsnd yz⟩ ❙∈ ide_to_hf (HF'.prod a b) * ide_to_hf c ∧
hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
(UP ⟨DOWN x, hfst yz⟩))"
unfolding arr_to_hfun_def
using assms 5 6
by (metis (mono_tags, lifting) HCollect_iff hfst_conv hsnd_conv)
moreover have "⟨⟨DOWN x, hfst yz⟩, hsnd yz⟩
❙∈ ide_to_hf (prod a b) * ide_to_hf c"
proof -
have "⟨DOWN x, hfst yz⟩ ❙∈ ide_to_hf (HF'.prod a b)"
using assms x yz
by (metis (no_types, lifting) prod_def DOWN_membI UNIV_I hfst_conv
ide_to_hf_hf_to_ide prod_ide_eq timesE times_iff)
thus ?thesis
using yz assms(1-2) prod_ide_eq by auto
qed
ultimately show ?thesis
using assms(1-2) prod_ide_eq by auto
qed
thus ?thesis by auto
qed
qed
thus ?thesis by simp
qed
also have "... = UP ⦃yz ❙∈ ide_to_hf b * ide_to_hf c. yz ❙∈ DOWN (Fun h x)⦄"
proof -
have "⦃yz ❙∈ ide_to_hf b * ide_to_hf c.
hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
(UP ⟨DOWN x, hfst yz⟩))⦄ =
⦃yz ❙∈ ide_to_hf b * ide_to_hf c. yz ❙∈ DOWN (Fun h x)⦄"
proof -
have "⋀yz. yz ❙∈ ide_to_hf b * ide_to_hf c ⟹
hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
(UP ⟨DOWN x, hfst yz⟩))
⟷
yz ❙∈ DOWN (Fun h x)"
proof -
fix yz
assume yz: "yz ❙∈ ide_to_hf b * ide_to_hf c"
have 7: "UP ⟨DOWN x, hfst yz⟩ ∈ set (HF'.prod a b)"
using assms x yz UP_membI
by (metis (no_types, lifting) prod_def DOWN_membI UNIV_I hfst_conv
ide_to_hf_hf_to_ide prod_ide_eq timesE times_iff)
have 8: "Fun h x ∈ set (exp b c)"
proof -
have "Fun h x ∈ Cod h"
using assms x Fun_mapsto by blast
moreover have "Cod h = set (exp b c)"
using assms 0 lam_simps(3) par by auto
ultimately show ?thesis by blast
qed
show "hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
(UP ⟨DOWN x, hfst yz⟩))
⟷
yz ❙∈ DOWN (Fun h x)"
proof -
have "Fun (comp (eval b c) (HF'.prod h b)) (UP ⟨DOWN x, hfst yz⟩) =
UP (happ (DOWN (Fun h x)) (hfst yz))"
proof -
have "Fun (comp (eval b c) (HF'.prod h b)) (UP ⟨DOWN x, hfst yz⟩) =
restrict (Fun (eval b c) ∘ Fun (HF'.prod h b))
(set (HF'.prod a b))
(UP ⟨DOWN x, hfst yz⟩)"
using assms x yz 2 by simp
also have "... = Fun (eval b c)
(Fun (HF'.prod h b) (UP ⟨DOWN x, hfst yz⟩))"
using 7 by simp
also have "... = Fun (eval b c)
(UP ⟨DOWN (Fun h x),
DOWN (Fun b (UP (hfst yz)))⟩)"
proof -
have "Fun (HF'.prod h b) (UP ⟨DOWN x, hfst yz⟩) =
UP ⟨DOWN (Fun h x), DOWN (Fun b (UP (hfst yz)))⟩"
proof -
have "Fun (HF'.prod h b) (UP ⟨DOWN x, hfst yz⟩) =
UP ⟨DOWN (Fun h (UP (hfst (DOWN (UP ⟨DOWN x, hfst yz⟩))))),
DOWN (Fun b (UP (hsnd (DOWN (UP ⟨DOWN x, hfst yz⟩)))))⟩"
proof -
have "UP ⟨DOWN x, hfst yz⟩ ∈ set (prod (dom h) (dom b))"
using assms x yz 7
by (metis (no_types, lifting) ideD(2) in_homE prod_ide_eq)
thus ?thesis
using assms x yz Fun_prod ideD(1) by blast
qed
also have "... = UP ⟨DOWN (Fun h (UP (DOWN x))),
DOWN (Fun b (UP (hfst yz)))⟩"
using assms x yz by simp
also have "... = UP ⟨DOWN (Fun h x), DOWN (Fun b (UP (hfst yz)))⟩"
using assms(1) set_subset_Univ x by force
finally show ?thesis by simp
qed
thus ?thesis by simp
qed
also have "... = Fun (eval b c) (UP ⟨DOWN (Fun h x), hfst yz⟩)"
using assms x yz Fun_ide ide_char UP_membI by auto
also have "... = restrict (λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
(set (HF'.prod (exp b c) b))
(UP ⟨DOWN (Fun h x), hfst yz⟩)"
using assms Fun_eval [of b c] by simp
also have "... = (λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
(UP ⟨DOWN (Fun h x), hfst yz⟩)"
proof -
have "UP ⟨DOWN (Fun h x), hfst yz⟩
∈ set (HF'.prod (exp b c) b)"
proof -
have 1: "ide_to_hf (HF'.prod (exp b c) b) =
HF (DOWN ` set (HF'.prod (exp b c) b))"
unfolding ide_to_hf_def by blast
have "⟨DOWN (Fun h x), hfst yz⟩
❙∈ HF (DOWN ` set (HF'.prod (exp b c) b))"
using assms x yz 1 8 Fun_mapsto [of h]
by (metis (no_types, lifting) prod_def DOWN_membI UNIV_I
hfst_conv ide_exp ide_to_hf_hf_to_ide prod_ide_eq timesE times_iff)
thus ?thesis
using assms x yz 1 UP_membI [of "⟨DOWN (Fun h x), hfst yz⟩"]
by auto
qed
thus ?thesis by simp
qed
also have "... = UP (happ (DOWN (Fun h x)) (hfst yz))"
by simp
finally show ?thesis by simp
qed
hence 9: "DOWN (Fun (comp (eval b c) (HF'.prod h b))
(UP ⟨DOWN x, hfst yz⟩)) =
happ (DOWN (Fun h x)) (hfst yz)"
by simp
show ?thesis
proof -
have "hsnd yz = happ (DOWN (Fun h x)) (hfst yz)
⟷ yz ❙∈ DOWN (Fun h x)"
proof
have 10: "∃!z. ⟨hfst yz, z⟩ ❙∈ DOWN (Fun h x)"
proof -
have "hfun (ide_to_hf b) (ide_to_hf c) (DOWN (Fun h x))"
using assms x 8
by (metis (no_types, lifting) DOWN_membI HCollect_iff UNIV_I
exp_def hexp_def ide_exp ide_to_hf_hf_to_ide)
thus ?thesis
using assms yz
hfunE [of "ide_to_hf b" "ide_to_hf c" "DOWN (Fun h x)"]
by (metis (no_types, lifting) hfst_conv timesE)
qed
show "yz ❙∈ DOWN (Fun h x)
⟹ hsnd yz = happ (DOWN (Fun h x)) (hfst yz)"
proof -
assume yz1: "yz ❙∈ DOWN (Fun h x)"
show "hsnd yz = happ (DOWN (Fun h x)) (hfst yz)"
unfolding app_def
using assms x yz yz1 10 hfun_arr_to_hfun arr_to_hfun_def
the1_equality
[of "λy. ⟨hfst yz, y⟩ ❙∈ DOWN (Fun h x)" "hsnd yz"]
by (metis (no_types, lifting) hfst_conv hsnd_conv timesE)
qed
show "hsnd yz = happ (DOWN (Fun h x)) (hfst yz)
⟹ yz ❙∈ DOWN (Fun h x)"
unfolding app_def
using assms x yz 10
theI' [of "λy. ⟨hfst yz, y⟩ ❙∈ DOWN (Fun h x)"]
by (metis (no_types, lifting) hfst_conv hsnd_conv timesE)
qed
thus ?thesis
using 9 by simp
qed
qed
qed
thus ?thesis by blast
qed
thus ?thesis by simp
qed
also have "... = Fun h x"
proof -
have H: "Fun h x = restrict (λx. UP (happ (arr_to_hfun h) (DOWN x))) (Dom h) x"
proof -
have "arr h"
using assms by blast
thus ?thesis
using assms x Fun_char by simp
qed
also have "... = UP (happ (arr_to_hfun h) (DOWN x))"
using assms x par
by (metis (no_types, lifting) 0 lam_simps(2) restrict_apply)
also have "... = UP (THE g. ⟨DOWN x, g⟩ ❙∈ arr_to_hfun h)"
using app_def by simp
also have "... = UP ⦃yz ❙∈ ide_to_hf b * ide_to_hf c. yz ❙∈ DOWN (Fun h x)⦄"
proof -
have ex_un_g: "∃!g. ⟨DOWN x, g⟩ ❙∈ arr_to_hfun h"
using assms x arr_to_hfun_def hfun_arr_to_hfun
hfunE [of "ide_to_hf a" "ide_to_hf (exp b c)" "arr_to_hfun h"]
by (metis (no_types, lifting) DOWN_membI in_homE)
moreover have
"⟨DOWN x, ⦃yz ❙∈ ide_to_hf b * ide_to_hf c. yz ❙∈ DOWN (Fun h x)⦄⟩
❙∈ arr_to_hfun h"
proof -
have "DOWN (Fun h x) =
⦃yz ❙∈ ide_to_hf b * ide_to_hf c. yz ❙∈ DOWN (Fun h x)⦄"
proof
fix yz
show "yz ❙∈ DOWN (Fun h x) ⟷
yz ❙∈ ⦃yz ❙∈ ide_to_hf b * ide_to_hf c. yz ❙∈ DOWN (Fun h x)⦄"
proof
show "yz ❙∈ DOWN (Fun h x)
⟹ yz ❙∈ ⦃yz ❙∈ ide_to_hf b * ide_to_hf c. yz ❙∈ DOWN (Fun h x)⦄"
proof -
assume yz: "yz ❙∈ DOWN (Fun h x)"
have "yz ❙∈ ide_to_hf b * ide_to_hf c"
proof -
have "DOWN (Fun h x) ❙∈ hexp (ide_to_hf b) (ide_to_hf c)"
proof -
have "ide (hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c)))"
using assms exp_def ide_exp by auto
moreover have
"Fun h x ∈ set (hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c)))"
proof -
have "Fun h x ∈ Cod h"
using assms x Fun_mapsto by blast
moreover have
"Cod h = set (hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c)))"
using assms 0 exp_def lam_simps(3) par by auto
ultimately show ?thesis by blast
qed
ultimately show ?thesis
using DOWN_membI [of "hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c))"
"Fun h x"]
by (simp add: ide_to_hf_hf_to_ide)
qed
thus ?thesis
using assms yz hexp_def by auto
qed
thus ?thesis
using assms x yz by blast
qed
show "yz ❙∈ ⦃yz ❙∈ ide_to_hf b * ide_to_hf c. yz ❙∈ DOWN (Fun h x)⦄
⟹ yz ❙∈ DOWN (Fun h x)"
using assms by simp
qed
qed
moreover have "UP (DOWN x) = x"
using assms x ide_char set_subset_Univ UP_DOWN
by (meson subsetD)
ultimately show ?thesis
using assms x arr_to_hfun_def ex_un_g by auto
qed
ultimately show ?thesis
using assms x theI' [of "λg. ⟨DOWN x, g⟩ ❙∈ arr_to_hfun h"]
by fastforce
qed
finally show ?thesis
using assms x by simp
qed
finally show ?thesis by simp
qed
ultimately show "Fun (Λ a b c (comp (eval b c) (HF'.prod h b))) x = Fun h x"
by blast
qed
qed
qed
section "The Main Results"
interpretation cartesian_closed_category comp
proof -
interpret elementary_cartesian_closed_category comp pr0 pr1
some_terminal trm exp eval Λ
using ide_exp eval_in_hom lam_in_hom prod_ide_eq eval_prod_lam lam_eval_prod
by unfold_locales auto
show "cartesian_closed_category comp"
using is_cartesian_closed_category by simp
qed
theorem is_cartesian_closed_category:
shows "cartesian_closed_category comp"
..
theorem is_category_with_finite_limits:
shows "category_with_finite_limits comp"
proof
fix J :: "'j comp"
assume J: "category J"
interpret J: category J
using J by simp
assume finite: "finite (Collect J.arr)"
have "has_products (Collect J.ide)"
proof -
have "Collect J.ide ≠ UNIV"
using J.not_arr_null by blast
moreover have "finite (Collect J.ide)"
proof -
have "Collect J.ide ⊆ Collect J.arr"
by auto
thus ?thesis
using finite J.ideD(1) finite_subset by blast
qed
ultimately show ?thesis
using finite has_finite_products' by simp
qed
moreover have "has_products (Collect J.arr)"
proof -
have "Collect J.arr ≠ UNIV"
using J.not_arr_null by blast
thus ?thesis
using finite has_finite_products' by simp
qed
ultimately show "has_limits_of_shape J"
using J.category_axioms has_limits_if_has_products [of J] by simp
qed
end
end